\ ceb.txt  Leo Wong 25 March 02003 fyj +
\ Chemical Equation Balance
\ See usage example at the end of this file

include from.txt

from Tools.txt
from String.txt
from Linked.txt

\ Place to enter and massage equation
CREATE Scratch 256 CHARS ALLOT

\ Hold element names and counters
linked Scale

\ Delete spaces, append zero
: Compress  ( s -- )
   DUP >R COUNT OVER SWAP
   0 ?DO >R COUNT DUP BL <> IF R> TUCK C! CHAR+ ELSE DROP R> THEN LOOP
   NIP 0 OVER C! R@ - /char /  R> C! ;
 
\ Convert digits to n; also leave address of last digit
: -Digits  ( ca -- n ca' )
   DUP 0 >R BEGIN DUP C@ digit? WHILE R> 1+ >R CHAR+ REPEAT
   SWAP R> DUP IF EVALUATE ELSE NIP THEN  SWAP /char - ;

\ Multiple insert
: Inserts  ( ca u s n # -- ca u s n )  0 ?DO 4dup insert LOOP  ;

\ Insert ca u into s a n according to digits at a
: Expand() ( ca u s n a -- a' )
   CHAR+ -Digits >R DUP 1 >
     IF 1- DUP >R Inserts 2DROP NIP R> * R> + 1-
     ELSE DROP 2DROP 2DROP R> THEN ;

\ Expand parenthetical expressions in s
: Expand()s  ( s -- )
   DUP COUNT
   0 ?DO SWAP >R
     DUP C@
     DUP [CHAR] ( = IF DROP DUP  ELSE
         [CHAR] ) = IF OVER - 1+ 
                      R@ DUP 2OVER + SWAP - 1-
                      2DUP CHARS + Expand()
                    THEN THEN
   CHAR+ R> SWAP LOOP  OVER - /char / 1-  SWAP C! ;

\ Seek uppercase character
: Scan-Upper  ( ca1 u1 -- ca2 u2 )
   BEGIN DUP WHILE OVER C@ upper? 0= WHILE 1 /STRING REPEAT THEN ;

\ Next element
: Element  ( ca u -- ca1 u1 ca2 u2 )
   Scan-Upper 2DUP 2>R 1 /STRING 0 MAX Scan-Upper DUP 2R> ROT - ;

\ Seek non-alphabetic character
: Skip-Alpha  ( ca1 u1 -- ca2 u2 )
   BEGIN DUP WHILE OVER C@ alpha? WHILE 1 /STRING REPEAT THEN ;

\ Return element symbol
: Element-Name  ( ca u -- ca1 u1 ca2 u2 )
    2DUP 2>R 1 /STRING 0 MAX Skip-Alpha DUP 2R> ROT - ;

\ Go to element symbol in node data
: >Symbol  ( data -- element-symbol )  2 CELLS + ;

\ Go to an element's reactant or product counter
DEFER >Meter  ' noop IS >Meter


\ Add an element to the list
: Add-Element  ( a u list -- a u node )
   link HERE 1 CELLS - >R  0 , 0 , string, R>  ;

\ Zero and element's counters
: zeroElement  ( node -- )  0 0 ROT >data 2! ;
\ Zero counters in the list
: 0scale  ( list -- )  ['] zeroElement IS xNode  xlist ; 

\ Balanced flag
TRUE VALUE Balanced

\ Display element data; equation unbalance if counters differ
: Element?  ( node -- )
   >data DUP 2@ 2DUP OR
   IF 2>R
     >Symbol COUNT TYPE SPACE 
     2R> 2DUP 0 .R [CHAR] / EMIT 0 .R 2 SPACES
     = 0= IF FALSE TO Balanced THEN
   ELSE 2DROP DROP THEN ;
  
\ Report if balanced
: ?Balanced  ( -- )
   Balanced IF ." Balanced" Else ." Unbalanced" THEN ;

\ Run through element list and report
: report  ( list -- )  ['] Element? is xNode  CR xList ?Balanced ;

\ Holds current coefficient of current compound
0 VALUE coefficient

\ Increment an element's counter
:noname  >data >Symbol ; IS >comp  \ for inlist?
: Tally-Element  ( a u -- a' u' )
    Element Element-Name Scale inlist? ?DUP
    0= IF Scale Add-Element ELSE NIP NIP THEN >R
    DROP -Digits DROP 1 MAX Coefficient * R> >data >meter +! ;

\ Increment the counters of elements in a compound
: Tally-Compound  ( a u -- )
   1 TO Coefficient
   OVER -Digits DROP 1 MAX TO Coefficient
   BEGIN DUP WHILE Tally-Element REPEAT 2DROP ;

\ Increment counters of one side of the equation
: Tally-Compounds  ( a u -- )
   BEGIN DUP 0> WHILE [CHAR] + split Tally-Compound 1 /STRING REPEAT
   2DROP ;

\ Increment reactants
: Tally-Reactants  ( a u -- )  ['] noop IS >meter  Tally-Compounds ;

\ Increment products
: Tally-Products  ( a u -- )  ['] CELL+ IS >meter  Tally-Compounds ;

\ Increment reactants and products
: Weigh  ( a u -- )
   [CHAR] > split  Tally-Reactants  1 /STRING Tally-Products ;

\ Get equation, weigh and report
: Balance  ( -- )
   Scale 0scale  TRUE TO Balanced
   Scratch >R 0 PARSE R@ place R@ Compress R@ Expand()s R> COUNT Weigh
   Scale Report ;


\ Usage example:
\   Balance Ca(OH)2 + 2HNO3 --> Ca(NO3)2 + 2H2O
\
\   displays:  Ca 1/1  O 8/8  H 4/4  N 2/2  Balanced
\
\ Element symbols have uppercase initials and lowercase remainder
\ Integer coefficients only