Fresh Fish 5/FreshFish_July-August1994.bin/bbs/misc/chembalance-3.0.lha/ChemBalance-3.0/ChemBalance

Text File | 1994-03-29 | 74KB | 2,870 lines

/********************************************************/
/*                                                      */
/*   This is ChemBalance, v3.0 which balances           */
/*   chemical equations.  You can input up to nine      */
/*   terms total. This program is developed by Patrick  */
/*   Reany, who reserves copyright to it. However,      */
/*   permission is granted to all to use it free of     */
/*   cost. All that's asked is the maintenance of the   */
/*   title, "ChemBalance", the version number and       */
/*   the author's name. Version 2.0 can be found on     */
/*   Fred Fish #916. This version allows for multiple   */
/*   generalized hydrations.                            */
/*                                                      */
/********************************************************/


       /***************************************/
       /*                                     */
       /*            ChemBalance, v3.0        */
       /*                                     */
       /*             Copyright 1994          */
       /*                                     */
       /***************************************/


/********************************************************/
/*     Prelims    Prelims    Prelims    Prelims         */
/********************************************************/

/*    options    */

   options prompt "--->  "

/*  error signals  */

   signal on ioerr
/*   signal on novalue */
   signal on error

signal bypass  /* jump to Initializations */

   exitscript:    say "Exiting script."; exit

   error  : call report(sigl, "ERROR");  signal exitscript
   novalue: call report(sigl, "NOVALUE");  signal exitscript
   ioerr  : call report(sigl, "IOERR");  signal exitscript

   report: procedure expose rc
      parse arg sl, text
      pen1 = '1b'x"[31m"; pen2 = '1b'x"[32m"
      say pen2 || text || pen1 "trap (rc =" rc", sigl =" sl") ."
   return


bypass:

/* call close("STDOUT")
if open("STDOUT",'vdk:checkfile','w') then
  say "Checkfile open......" */

/********************************************************/
/*          Initializations         Initializations     */
/********************************************************/

address command 'echo "*ec"'
say
say "This is ChemBalance, version 3.0:"
say

/*    constants     */

   true  = 1
   false = 0
   lowerletters = xrange('a','z')
   upperletters = xrange('A','Z')
   digits       = xrange('0','9')


/*     variables     */

   errortesting = false
   looking_for_nonregular_solutions = false

restart:

   cycle_count = 0
   #elements.@side.1 = 0 /* This will count # of elements */
   #elements.@side.2 = 0
   elements_list.@side.1 = ""
   elements_list.@side.2 = ""
   do i=1 to 3
     what_side.2.term_list.i.element_count = 0
   end

   /* These last two initializations begin the lists*/
   /* that will contain all elements on each side. */
   /* Each list will contain only one entry for each */
   /* element on the respective sides. */

  if looking_for_nonregular_solutions then
    looking_for_nonregular_solutions = false
  /*  trace ?r  */

   do i=1 to 20
      UDcoef.i = 0    /* UD  = user defined */
   end
   UDCcount = 0    /* UDC = user defined coefficient */
   UDCineffect = false
   doing_negative_values = false

/*************************************************************/
/*     Main      Main       Main       Main        Main      */
/*************************************************************/

call look_for_syntax_errors /* Not ARexx syntax errors, */
       /*   but user-input errors.  */

begin_nonregular:
/* trace ?r */
if looking_for_nonregular_solutions then
  do
    parse var $unequation LHS "=" RHS
    elements_list.@side.1 = ""
    elements_list.@side.2 = ""
    #elements.@side.1 = 0
    #elements.@side.2 = 0
    cycle_count = 0
    do i=1 to 10
      UDcoef.i = 0
    end
    UDCcount = 0
    UDCineffect = false
    doing_negative_values = false
    call more_errors() /* needed to initialize some values */
  end

call get_started

restart2:
RHSprime = ""     /* The variables hold the homogeneous forms */
LHSprime = ""     /* to be put into make_new_equation.        */
if errortesting then
  if ~UDCineffect then do
    say "Just obeyed call to 'restart2'"
    say "Just before 'process(LHS)':"
    say "    LHS = " LHS
    say "    RHS = " RHS
  end
/* trace ?r */
call process(LHS,1)
if errortesting then do
    say "EO process(LHS) ********************** "
  end
call process(RHS,2)
if errortesting then do
    say "EO process(RHS) ********************** "
  end

if ~doing_negative_values then
  if belated_error() then do
     say
     say "ERROR: Each element does not appear on both sides."
     say "Check for spelling errors."
     say
     signal restart
    end
if UDCineffect then do
  UDCineffect = false
  call make_new_equation

/*  trace ?r  */

  LHS! = LHS
  RHS! = RHS
  #LH_terms = words(LHS)
  #RH_terms = words(RHS)
  #total_terms = #LH_terms + #RH_terms
  elements_list =  elements_list.@side.2
  signal restart2
end

/*  trace ?r  */
call calculate_answer
if errortesting then say "EO calculate_answer"
call print_answer(#total_terms-1)
call verify_solution

if exists(interval) then do
    finish_time = time()
    say "time interval = "interval(start_time,finish_time)
    end
  else do
    say "finish_time = " time()
    say "start_time  = " start_time
  end

signal restart  /*********           End Main        **********/


/*************************************************************/
/*                                                           */
/*   Functions      Functions      Functions      Functions  */
/*                                                           */
/*************************************************************/


/*************************************************************/
/*     look_for_syntax_errors     look_for_syntax_errors     */
/*************************************************************/

look_for_syntax_errors:
/* trace ?r */

errors = true

do while errors /**/
  say " "
  say "Input unbalanced equation..."
  say " "
  parse pull unequation
  start_time = time()
  if unequation ~= "" then
   if ~syntax_OK(unequation) then do
       say "Use only alphanumeric, parens, `+', `=', '*', or `_'"
        signal restart
       end
     else if upper(unequation)='QUIT' then do
           say
           say "Quiting ChemBalance."
           say
          exit; end
       else
        if ~elements_OK(unequation) then do
           say
           say "Elements must be single capital letters"
           say "or a capital letter and a small case letter."
           say
           say "Perhaps you wrote a capital letter in "
           say " lower case."
           say
           signal restart; end
         else
         if ~parse_OK(unequation) then do
            say error_msg; signal restart; end
          else
           if more_errors() then do
             say error_msg; signal restart; end
            else
             if ~underscoresOK(unequation) then do
                say error_msg;  signal restart; end
                else errors = false
end /**/
return

/*************************************************************/
/*  get_started    get_started    get_started    get_started */
/*************************************************************/

get_started:
if errortesting then do
     say "  LHS = "LHS
   end
if looking_for_nonregular_solutions then do
  originalLHS = LHS
  originalRHS = RHS
end
LHS! = LHS
RHS! = RHS
/* trace ?r */
original_eq = " "||LHS||" "||RHS
call get_original_stripped_eq()
say original_stripped_eq

#originally_on_left = words(LHS)
#originally_on_right = words(RHS)
call preprocess(LHS,1)/*Puts all terms with coef on right side */
call preprocess(RHS,2)
eq = LHS||" "||RHS
#Lterms = words(LHS)
#Rterms = words(RHS)
if #Lterms+#Rterms>20 then do
  say "You can only use up to 20 terms. Sorry."
  signal restart
end
if ~parensOK(eq) then do
   say; say error_msg;  signal restart
  end
call process_for_UDCs /*This strips off the UD coefficients */
if errortesting then do
  say "Just after 'process_for_UDCs':"
  say "    LHS = " LHS
  say "    RHS = " RHS
end


call convert_asterisk(1)
if errortesting then do
     say "  LHS = " LHS
   end
call convert_asterisk(2)
if errortesting then do
     say "  RHS = " RHS
   end
return

get_original_stripped_eq:
if looking_for_nonregular_solutions then
    do
      /* trace ?r */
      original_stripped_eq=$originalL||" "||$originalR
      return
    end
  else do /**/
    os_eq=original_eq
    do_again:
    do i=2 to length(os_eq) /****/
      position=pos(char(os_eq,i),digits)
      if position>0 & pos(char(os_eq,i-1)," ")>0 then
        do /******/
          os_eq=delstr(os_eq,i,1)
          signal do_again
        end /******/
    end /****/
    original_stripped_eq=os_eq
    return
  end /**/


/*************************************************************/
/*    syntax_OK     syntax_OK      syntax_OK    syntax_OK    */
/*************************************************************/


syntax_OK: procedure expose errortesting true false lowerletters upperletters digits
/*  trace ?r */
if errortesting then say "entering 'syntax_OK'"
equation = arg(1)
misc         = '()+=*_ '

error = false
do i=1 to length(equation) while ~error
  ch  = char(equation,i)
  in_lowers = pos(ch,lowerletters)
  in_uppers = pos(ch,upperletters)
  in_numeric= pos(ch,digits)
  in_misc   = pos(ch,misc)
  if in_lowers + in_uppers + in_misc + in_numeric = 0
     then error = true
end

return ~error


/*************************************************************/
/*        elements_OK     elements_OK      elements_OK       */
/*************************************************************/


elements_OK: procedure expose errortesting true false lowerletters upperletters digits

/*  trace ?r */

equation = arg(1)
error = false
if first_char_lower() then error = true
  else do
    do i=2 to length(equation) while ~error
      ch  = char(equation,i)
      ch! = char(equation,i-1)
      if pos(ch,lowerletters)>0 & pos(ch!,upperletters)=0 then
         error = true
    end
  end

return ~error

first_char_lower:
if pos(char(equation,1),lowerletters)>0 then return true
  else return false



/*************************************************************/
/*      parse_OK      parse_OK      parse_OK     parse_OK    */
/*************************************************************/


parse_OK: procedure expose errortesting error_msg RHS LHS digits

equation = arg(1)

if errortesting then say "entering 'parse_OK'"

if index(equation,"=")=0 then do
  error_msg = "Where is the '=' sign?"
  return 0
  end
else do
  leftmostleftpart = ""
  leftmostrightpart = ""
  parse var equation leftside"="rightside
  do while index(leftside,"+") > 0
    parse var leftside leftmostpart"+"leftside
    leftmostleftpart = leftmostleftpart||" "||leftmostpart
    end
  LHS = leftmostleftpart ||" "|| leftside

  do while index(rightside,"+") > 0
    parse var rightside leftmostpart"+"rightside
    leftmostrightpart = leftmostrightpart||" "||leftmostpart
    end
  RHS = leftmostrightpart ||" "|| rightside
  say LHS RHS
  return 1
end


/*************************************************************/
/*       more_errors     more_errors     more_errors         */
/*************************************************************/


more_errors:


#LH_terms = words(LHS)
#RH_terms = words(RHS)
#total_terms = #LH_terms + #RH_terms
if #total_terms < 3 then do
    error_msg = "Equation must have 3 or more terms total."
    goof = true
    end
  else goof = false


do i=1 to 2
    if i=1 then #terms = #LH_terms
          else #terms = #RH_terms
    do j=1 to #terms
       what_side.i.term_list.j.element_count = 0
    end
end

return goof



/*************************************************************/
/*     underscoresOK     underscoresOK     underscoresOK     */
/*************************************************************/

underscoresOK: procedure expose errortesting error_msg true false digits upperletters lowerletters

/*  trace ?r */

if errortesting then say "Entering `underscoresOK'"

equation = arg(1)

error = false
do i=1 to words(equation) while ~error /**/
  more_underscores = true
  present_word = word(equation,i)
  do while more_underscores & ~error /***/
    position = pos("_",present_word)
    if position=0 then
        more_underscores = false
     else
      if position=1 then do
        error_msg= "Underscore can not be first char in word."
        error = true
        end
       else
        if position=length(present_word) then
           do
             error_msg=,
             "You can't place underscore at end of term."
             error = true
           end
          else
           do /****/
            ch = char(present_word,position-1)
            if ch~=')' & pos(upper(ch),upperletters)=0 then
               do
                error_msg="underscore must be preceded by",
                  ||" either a ')' or an alphabetic char."
                error = true; break
               end
             else
              do /*****/
               ch = char(present_word,position+1)
               if pos(ch,digits)=0 then do
                 error_msg="Must have digit immediately after",
                   ||" an underscore.";  error = true; end
                else
                  parse var present_word stuff '_' present_word
              end /*****/
           end /****/
  end /***/
  if error then break
end /**/

return ~error


/*************************************************************/
/*    parensOK   parensOK   parensOK   parensOK   parensOK   */
/*************************************************************/

parensOK: procedure expose error_msg errortesting true false digits

if errortesting then
  say "Entering 'parensOK'."

/*  trace ?r */

equation = arg(1)

error = false
do ii=1 to words(equation) while ~error /**/
  term = word(equation,ii)
  len = length(term)
  if char(term,len)=')'|char(term,len)='(' then do
     error = true; error_msg='Cannot have parenthesis as',
     ||' last char in term.'
     signal jump1
   end
end
do ii=1 to words(equation) while ~error /**/
  current_term = word(equation,ii)
  R_index = pos(")",current_term)
  L_index = pos("(",current_term)
  len = length(current_term)
  if R_index=len | L_index=len then do
    error = true; error_msg='Cannot have parenthesis as',
     ||' last char in term.'
    end
   else do /***/
    #R = how_many(")",current_term)
    #L = how_many("(",current_term)
    if #R>0 then do
      lastposRparen = 0
      do i#=1 to #R
        do until char(current_term,i#)=")"
          i#=i#+1
        end
        if char(current_term,i#+1)~="_" then do
          error = true
          error_msg="Parenthesis error! Right parens",
            ||" must have '_' following!"
          break
          end
        else
          lastposRparen = i#
      end
    end

    if #R=0 & #L=0 then iterate ii
     else if #R=1 & #L=1 then do
          if R_index>=L_index+2 then iterate ii
              else do error_msg= "Mismatched parentheses!"
                   error=true; break; end
          end
       else if #R~=#L then do
            error_msg= "Mismatched parentheses!"; error=true; end

   end /***/

end /**/
jump1:
return ~error



/*************************************************************/
/*      how_many     how_many     how_many     how_many      */
/*************************************************************/

how_many: procedure
/* trace ?r */
char   = arg(1)
string = arg(2)

count = 0
do while pos(char,string)>0
  count = count + 1
  len = length(string)
  string = right(string,len-pos(char,string))
end

return count



/*************************************************************/
/*      belated_error     belated_error     belated_error    */
/*************************************************************/

belated_error:

/* This checks to see if elements are same on both sides. */

/*  trace ?r */

if errortesting then say "entering 'belated_error'"

goof = false
original_elements_list = elements_list.@side.1
list.1 = sort(elements_list.@side.1)
list.2 = sort(elements_list.@side.2)
if compress(list.1)~=compress(list.2) then goof = true

return goof



/*************************************************************/
/*     char     char     char     char     char     char     */
/*************************************************************/

char: procedure

/* trace ?r */

string = arg(1)
indx   = arg(2)
if indx > length(string) then return 0
  else return substr(string,indx,1)



/*************************************************************/
/*     sort     sort     sort     sort     sort     sort     */
/*************************************************************/

sort: procedure expose errortesting List_of_elements

if errortesting then say "Entering function 'sort'"
if ~exists('ram:sort') then
       address command 'copy c:sort to ram:sort'

List_of_elements = arg(1)
if errortesting then do
  say "List of elements = " arg(1)
end
file = 'ram:list'
ramfile = 'ramfile'

/*  trace ?r */

if open(ramfile,file,'w') then do
  @count = words(List_of_elements)
  do i=1 to @count
    call writeln(ramfile,word(List_of_elements,i))
  end
  call close(ramfile)
  address command 'ram:sort ram:list ram:mylist'

  elementslist = ""
  myfile = 'ram:mylist'
  ram_myfile ='ram_myfile'
  if open(ram_myfile,myfile,'r')then do
    do i=1 to @count
       next_element = readln(ram_myfile)
       if next_element~='(' & next_element~=')' then
         elementslist = elementslist || next_element
    end
    call close(ram_myfile)
  end
end
return elementslist



/*************************************************************/
/*   convert_asterisk   convert_asterisk   convert_asterisk  */
/*************************************************************/

convert_asterisk: procedure expose LHS RHS errortesting true false digits

/* trace ?r */

if errortesting then
    say "Entering convert_asterisk."

if arg(1)=1 then string = LHS
     else string = RHS
newstring = ""
do z=1 to words(string)
  tempstring = fix_next_term(word(string,z))
  newstring = newstring||" "||tempstring
end
if arg(1) = 1 then LHS = newstring
  else RHS = newstring

/* end convert_asterisk */
return


fix_next_term: procedure expose true false digits errortesting

string = arg(1)
/*  trace ?r */
if pos("*",string)=0 then more_asterisks = false
    else more_asterisks = true
do while more_asterisks /**/
  if pos("*",string)=0 then more_asterisks = false
    else do /***/
      parse var string LHstuff "*" RHstuff
      factor = 1
      if pos(left(RHstuff,1),digits) > 0 then do /**+**/
          factor = left(RHstuff,1)
          RHstuff = delstr(RHstuff,1,1)
          end /**+**/
      if pos(left(RHstuff,1),digits) > 0 then do /*****/
          factor = factor||left(RHstuff,1,1)
          RHstuff = delstr(RHstuff,1,1)
          end /*****/
      if pos("*",RHstuff)>0 then do
          parse var RHstuff middlestuff "*" farrightstuff
          left = LHstuff||"("||middlestuff||")"
          string = left||"_"||factor||"*"||farrightstuff
        end
      else
        do /*****/
           string = LHstuff||"("||RHstuff||")"||"_"||factor
        end /*****/
      if errortesting then say " string = " string
    end /***/
end/**/
return string


/*************************************************************/
/*         preprocess     preprocess     preprocess          */
/*************************************************************/


preprocess: /* puts all coefficioned terms to far right */

if errortesting then say "entering 'preprocess'"

/*  trace ?r */

sideterms = arg(1)
side#$ = arg(2)
Lstuff = " "
Rstuff = " "
#terms = words(sideterms)
rightmostterms = ""
do i=1 to #terms
  parse var sideterms leftmostterm  sideterms
  if pos(char(leftmostterm,1),digits)=0 then
    Lstuff = Lstuff||" "||leftmostterm
  else
    rightmostterms = rightmostterms||" "||leftmostterm
end
if side#$ = 1 then LHS = Lstuff||" "||rightmostterms
  else RHS = Lstuff||" "||rightmostterms

return /* from: preprocess */




/*************************************************************/
/*         make_new_equation       make_new_equation         */
/*************************************************************/


make_new_equation:

/* Since ChemBalance cannot do nested parens I decided to deal with UDC's this way:
1) preprocess the equation to eliminate asterisks and parens, but don't send the result to 'add_to_elements_list' yet.
2) Take each term that has subscripts and convert it to a paren pair.
For example, consider converting the term 4Ca(OH)_2*3H_2O first to 4CaO_2H_2H_6O_3 and then to (CaO_2H_2H_6O_3)_4. Now this latter form is run thru the mill as though it were the original term. It's clever but it's also complicated, for the program's procedures must constantly decide they're doing negative values and whether UDCineffect.                                       */


if errortesting then say "entering 'make_new_equation'"

/*  trace ?r */
if errortesting then
  do i=1 to #Rterms+#Lterms
    say "UDcoef."i" = " UDcoef.i
  end

newLHS = " "
#Lterms = words(LHS)
transferterm = ""
do i=1 to #Lterms
  parse var LHS leftmostterm  LHS
  if UDcoef.i ~= 0 then
    transferterm = transferterm,
         ||"["||compress(leftmostterm)||"]_"||UDcoef.i
  else
    newLHS = newLHS||" "||leftmostterm
end
LHS = newLHS

newRHS = " "
#Rterms = words(RHS)
termstomoveright = " "
do i=#Lterms+1 to #Rterms+#Lterms
  parse var RHS leftmostterm  RHS
  if UDcoef.i ~= 0 then
    termstomoveright = termstomoveright,
          ||"("||compress(leftmostterm)||")_"||UDcoef.i
  else
    newRHS = newRHS||" "||leftmostterm
end
RHS = newRHS||" "||termstomoveright||transferterm

return



/*************************************************************/
/*         process_for_UDCs        process_for_UDCs          */
/*************************************************************/


process_for_UDCs: /* This strips off all coefficients and puts them in the array UDcoef.i */

if errortesting then say "entering 'process_for_UDCs'"

/*  trace ?r */

if errortesting then say "eq = " eq
Lstuff = " "
do ii=1 to words(eq) /**/
  if errortesting then say "ii = " ii
  if pos(left(word(eq,ii),1),xrange("1","9"))=0 then
        Lstuff = Lstuff||" "||word(eq,ii)
    else do /***/
      UDCcount = UDCcount + 1
      UDC = ""
      more_digits = true
      ith_term = word(eq,ii)
      do while more_digits /*^^*/
        UDC = UDC||char(ith_term,1)
        ith_term = right(ith_term,length(ith_term)-1)
        if pos(char(ith_term,1),digits) = 0 then
          more_digits = false
      end /*^^*/
      UDcoef.ii = UDC
      Lstuff = Lstuff||" "||ith_term
    end /***/
end /**/
/*  trace ?r */
if errortesting then
  do i=1 to 10
    say "UDcoef.i = " UDcoef.i
  end
/* trace ?r */
newequation = Lstuff
LHS = " "
do kk=1 to #Lterms
  LHS = LHS||" "||word(newequation,kk)
end
RHS = " "
do kk=1 to #Rterms
  RHS = RHS||" "||word(newequation,kk+#Lterms)
end
select
  when UDCcount = 0 then do
       UDCineffect = false
       doing_negative_value = false
       end
  when UDCcount = 1 then do /**/
    UDCineffect = false
    say
    say "If you use any user-defined coefficient then"
    say "use at least two."
    say
    signal restart
    end /**/
  otherwise do
/*  If words(eq)=3 then do

      say "You must solve this easy one without UDCs."
      say
      UDCineffect = false
      signal restart
      end
  else do*/
      UDCineffect = true
      doing_negative_values = true
    end
end /* select */
newequation = LHS||" "||RHS

return /* from process_for_UDCs */


/*************************************************************/
/*       process     process      process      process       */
/*************************************************************/


process:

if errortesting then say "entering 'process'"

/* This procedure removes the underscores to parens and to brackets but leaves the underscores to the individual elements for another procedure.                                         */


/* if ~UDCineffect then trace ?r */

terms    = arg(1)
ith_side = arg(2)
#terms   = words(terms)
If errortesting then say "terms = " terms
/*  trace ?r  */
do @w=1 to #terms
   term = word(terms,@w)
   do while pos(")",term) > 0
      call process_parens
      end
   do while pos("]",term) > 0
      call process_brackets
      end
   if ~UDCineffect then do /**/
     do while index(term,"_") > 0 /***/
        if errortesting then do
          say "@w =  " @w
          say "term_w = " term
          say
        end
        call remove_underscore(term,ith_side,@w)
        if Lterm ~= "" then
             call process_residue(Lterm,ith_side,@w)
      end /***/
      if term ~= "" then
         call process_residue(term,ith_side,@w)
   end  /**/
end


return /* from: process */



/*************************************************************/
/*     process_parens    process_parens   process_parens     */
/*************************************************************/


process_parens:

/*  trace ?r */
if errortesting then say "entering 'process_parens'"

/* elegant!!! */
parse var term Lstuff "(" innerstuff ")_" Rstuff
factor = ""
original_innerstuff = innerstuff
do while pos(left(Rstuff,1),digits) > 0
  factor = factor||left(Rstuff,1)
  Rstuff = right(Rstuff,length(Rstuff)-1)
end

changes_were_made = true
do while changes_were_made
  changes_were_made = false
  innerstufflength = length(innerstuff)
  do t=1 to innerstufflength-1
    if pos(upper(char(innerstuff,t)),upperletters) > 0
     then do
      nextchar! = char(innerstuff,t+1)
      if nextchar! ~="_" & pos(nextchar!,lowerletters) = 0
       then do
          innerstuff = insert("_1",innerstuff,t)
          changes_were_made = true
        end
     end
  end
end

if pos(upper(char(innerstuff,length(innerstuff))),upperletters)>0
 then innerstuff = innerstuff || "_1"
/*  trace ?r  */
more_underscores! = true
pos_last_underscore = 0
do while more_underscores! /**/
  pos_underscore = pos("_",innerstuff,pos_last_underscore+1)
  if pos_underscore=0 then more_underscores! = false
    else do /***/
      pos_last_underscore = pos_underscore
      more_digits! = true
      subscript = ""
      do count!=1 to length(innerstuff) while more_digits! /****/
         if pos_underscore+count! > length(innerstuff)
             then do
               more_digits! = false
               more_underscores! = false
               end
          else do /*****/
             negpresent = false
             char! = char(innerstuff,pos_underscore+count!)
             if pos(char!,digits)=0 then do
                more_digits! = false
                say "        Hi there!"
                end
              else
                subscript=subscript||char!
          end /*****/
          if negpresent then say "subscript = " subscript
       end /****/
     end /***/
  newsubscript = convert!(factor*subscript)
  innerstuff=left(innerstuff,pos_underscore),
   ||newsubscript||right(innerstuff,length(innerstuff),
                         -pos_underscore-length(subscript))

if errortesting then say " innerstuff = " innerstuff
end /**/


term = Lstuff||innerstuff||Rstuff
if doing_negative_values & UDCineffect then do /**/
  select
    when ith_side = 1 then do /************/
     /*  trace ?r */
       if @w=1 then do /***/
          LHSprime = term
          if #terms > 1 then
            do p=2 to #terms
              LHSprime = LHSprime||" "||word(LHS,p)
            end
          end /***/
        else do /*^*/
          do p=1 to @w-1
            LHSprime = LHSprime||" "||word(LHS,p)
          end
          LHSprime = LHSprime||" "||term
          if #terms > @w then
          do p=@w to #terms
            LHSprime = LHSprime||" "||word(LHS,p)
          end
        end /*^*/
      LHS = LHSprime
      if errortesting then say "LHSprime = " LHS
    end/************/
  when ith_side = 2 then do/************/
     /*  trace ?r */
       if @w=1 then do /***/
          RHSprime = term
          if #terms > 1 then
            do p=2 to #terms
              RHSprime = RHSprime||" "||word(RHS,p)
            end
          end /***/
        else do /*^*/
          RHSprime = ""
          do p=1 to @w-1
            RHSprime = RHSprime||" "||word(RHS,p)
          end
          RHSprime = RHSprime||" "||term
          if #terms > @w then
          do p=@w to #terms
            RHSprime = RHSprime||" "||word(RHS,p)
          end
        end /*^*/
      RHS = RHSprime
      if errortesting then say "RHSprime = " RHS
  end /*************/
  end /* select */
end
return /* from: process_parens */





/*************************************************************/
/*   process_brackets  process_brackets  process_brackets    */
/*************************************************************/


process_brackets:

/*  trace ?r */
if errortesting then say "entering 'process_parens'"


parse var term Lstuff "[" innerstuff "]_" Rstuff
factor = left(Rstuff,1)
Rlen = length(Rstuff)

Rstuff = right(Rstuff,Rlen-1)
changes_were_made = true
do while changes_were_made
  changes_were_made = false
  innerstufflength = length(innerstuff)
  do t=1 to innerstufflength-1
    if pos(upper(char(innerstuff,t)),upperletters) > 0
     then do
      nextchar! = char(innerstuff,t+1)
      if nextchar! ~="_" & pos(nextchar!,lowerletters) = 0
       then do
          innerstuff = insert("_1",innerstuff,t)
          changes_were_made = true
        end
     end
  end
end

if pos(upper(char(innerstuff,length(innerstuff))),upperletters)>0
 then innerstuff = innerstuff || "_1"
/*  trace ?r  */
more_underscores! = true
pos_last_underscore = 0
do while more_underscores! /**/
  pos_underscore = pos("_",innerstuff,pos_last_underscore+1)
  if pos_underscore=0 then more_underscores! = false
    else do /***/
      pos_last_underscore = pos_underscore
      more_digits! = true
      subscript = ""
      do count!=1 to length(innerstuff) while more_digits! /****/
         if pos_underscore+count! > length(innerstuff)
             then do
               more_digits! = false
               more_underscores! = false
               end
          else do /*****/
             char! = char(innerstuff,pos_underscore+count!)
             if pos(char!,digits)=0 then
                more_digits! = false
              else
                subscript=subscript||char!
          end /*****/
       end /****/
     end /***/
  newsubscript = "-"||convert!(factor*subscript)
  innerstuff=left(innerstuff,pos_underscore),
      ||newsubscript||right(innerstuff,length(innerstuff),
                        -pos_underscore-length(subscript))

if errortesting then say " innerstuff = " innerstuff
end /**/

term = Lstuff || innerstuff || Rstuff

return /* from: process_brackets */




/*************************************************************/
/*      convert!     convert!     convert!     convert!      */
/*************************************************************/


convert!: procedure

num = arg(1)
/* trace ?r */
select
  when num > 0 & num < 10 then do
       digit.1 = num
       digit.2 = "NIL"
       end
  when num >= 10 & num < 100 then do
       x = num//10
       y = trunc(num/10)
       digit.1 = x
       digit.2 = y
       digit.3 = "NIL"
       end
  when num >= 100 & num < 1000 then do
       z = trunc(num/100)
       y = trunc((num - 100*z)/10)
       x = num - 100*z - 10*y
       digit.1 = x
       digit.2 = y
       digit.3 = z
       digit.4 = "NIL"
       end
  otherwise do
       say
       say "Subscript value outside of valid range: 1--999"
       say
       signal restart; end
end

i = 1
rebuilt = ""
do until digit.i="NIL"
  rebuilt = digit.i || rebuilt
  i = i + 1
end

return rebuilt /* from: convert! */





/*************************************************************/
/*         remove_underscore        remove_underscore        */
/*************************************************************/


remove_underscore:

if errortesting then say "entering 'remove_underscores'"
/*  trace ?r */
_term  = arg(1)
_i     = arg(2)
_term# = arg(3)

parse var _term Lterm"_"Rterm
char = right(Lterm,1)
if upper(char) ~= char then do


next_element = right(Lterm,2)
        Lterm = left(Lterm,length(Lterm)-2) /* residue */
        end
     else do
        next_element = right(Lterm,1)
        Lterm = left(Lterm,length(Lterm)-1) /* residue */
     end

operant_term = Rterm
nextchar = left(operant_term,1)
#digits = 0
signal off novalue /*******************/
do while index('-0123456789',nextchar) > 0 then
   #digits = #digits + 1
   operant_term = right(operant_term,length(operant_term)-1)
   nextchar = left(operant_term,1)
end
signal on novalue
subscript = left(Rterm,#digits)

call add_to_elements_list(next_element,subscript,_i,_term#)
term = right(Rterm,length(Rterm)-#digits)

return /* from: remove_underscore */


/*************************************************************/
/*    process_residue   process_residue   process_residue    */
/*************************************************************/


process_residue:

if errortesting then say "entering 'process_residue'"
/*  trace ?r */

residue     = arg(1)
side_number = arg(2)
term_no     = arg(3)

subscript = 1
do while residue ~= ""
  len = length(residue)
  char = right(residue,1)
  if upper(char) ~= char then do
        next_element = right(residue,2)
        residue = left(residue,len-2)
      end
    else do
        next_element = right(residue,1)
        residue = left(residue,len-1)
    end
  next_el = next_element
  sub = subscript
  call add_to_elements_list(next_el,sub,side_number,term_no)
end
return /* from: process_residue */




/*************************************************************/
/*      add_to_elements_list         add_to_elements_list    */
/*************************************************************/


add_to_elements_list:


if errortesting then say "entering 'add_to_elements_list'"

/* As the function 'process_residue' goes element by element thru the terms of both sides of the equation, it sends the element and cound (from the subscript) to this function, which adds that count to the appropriate entry of the coefficient matrix (say C for symbolic representation) to be used to solve for x the matix equation Cx = const., where const. is a 'column' matrix.                                                      */

/*  trace ?r */

@element    = arg(1)
@q          = arg(2)
which_side  = arg(3)
@term#      = arg(4)

if errortesting then do
  say "@element    = " arg(1)
  say "@q          = " arg(2)
  say "which_side  = " arg(3)
  say "@term#      = " arg(4)
end
elementfound = false

q = what_side.which_side.term_list.@term#.element_count

if q > 0 then
 do y=1 to q while ~elementfound
   if errortesting then
      say "side.which_side.term_pos.@term#.element.y = ",
        side.which_side.term_pos.@term#.element.y
   if side.which_side.term_pos.@term#.element.y = @element
    then do
     $c = side.which_side.term_pos.@term#.element.y.count
     side.which_side.term_pos.@term#.element.y.count = $c + @q
     if errortesting then do
        say "                 $c = " $c
        say "                 @q = " @q
        say "      element count = " $c+@q
       end
     elementfound = true
     if y=q then do
       #nil_el = y + 1
       side.which_side.term_pos.@term#.element.#nil_el='NIL'
       side.which_side.term_pos.@term#.element.#nil_el.count=0
     end
   end
 end
/* trace ?r */
if ~elementfound then do
 /* Element not found in i,jth term: add it to term */
    q = q + 1
    what_side.which_side.term_list.@term#.element_count = q
    side.which_side.term_pos.@term#.element.q = @element
    side.which_side.term_pos.@term#.element.q.count = @q
    #nil_el = q + 1
    side.which_side.term_pos.@term#.element.#nil_el = 'NIL'
end
elements_list =  [e-mail]_side
if errortesting then do
    say
    say "add to elements list:"
    say "elements_list = " [e-mail]_side
  end
w = which_side
if compress(elements_list.@side.w)="" then do/*.....*/
   #elements.@side.w = #elements.@side.w + 1
   elements_list.@side.w=elements_list.@side.w||" "||@element
   if errortesting then do
      say "elements_list = " elements_list.@side.w
      say "No. of elements = " #elements.@side.w
      end
    end/*.....*/
  else
     do/**/
       /* trace ?r */
       elementfound = false
       do z=1 to words(elements_list.@side.w) while ~elementfound
         if @element~=word(elements_list.@side.w,z) then iterate
            else  elementfound = true
       end
       if ~elementfound then  call add_element()
     end/**/

return /* from: add_to_elements_list */


add_element:

#elements.@side.w = #elements.@side.w + 1
elements_list.@side.w=elements_list.@side.w,
     ||" "||@element
if errortesting then do
    say "elements_list = " elements_list.@side.w
    say "No. of elements = " #elements.@side.w
  end
return





/*************************************************************/
/*   calculate_answer   calculate_answer   calculate_answer  */
/*************************************************************/


calculate_answer:/* This uses Cramer's rule. */

if errortesting then say "entering 'calculate answer'"

/* trace ?r */

if ~doing_negative_values then
  elements_list = original_elements_list
#equations_needed = words(LHS) + words(RHS) - 1
#elements = words(elements_list)
if errortesting then do
  say "#elements = " #elements
  say "elements_list = " elements_list
end
if #equations_needed > #elements then
  if ~doing_negative_values then
   do
    if ~looking_for_nonregular_solutions then
       signal decide_on_nonregular()
   end
/*  trace ?r */
 rrr = 0
 do for #equations_needed/**/
    rrr = rrr + 1
    current_element = word(elements_list,rrr)
    if errortesting then
         say "elements_list = " elements_list
    do ii=1 to 2 /***/
      if ii=1 then number_terms = #LH_terms
            else number_terms = #RH_terms
      do jj=1 to number_terms /****/
        if ii=1 then pp = jj
           else  pp = jj + #LH_terms
        elementfound = false
        more_elements = true
        kk = 0
        do while ~elementfound & more_elements  /*****/
           kk = kk + 1
           if errortesting then do
              say "kth element i,jth term: "
              say  side.ii.term_pos.jj.element.kk
            end
           zz = side.ii.term_pos.jj.element.kk
           if zz='NIL' then  more_elements = false
             else do
              zz_count = side.ii.term_pos.jj.element.kk.count
              if zz=current_element then do
                 coef.row.rrr.column.pp = (-1)**(ii+1)*zz_count
                 elementfound = true
                 end
             end
         end/*****/
         if ~elementfound then coef.row.rrr.column.pp = 0
      end/****/
    end/***/
end/**/
select
   when #equations_needed=1 then call calculate1
   otherwise call calculate(#equations_needed)
end

return /* from: calculate_answer */

decide_on_nonregular:
say
say "This equation has too few elements, compared to"
say "the no. of terms present, to determine the coef's."
say "Algorithm needs at least as many as one less"
say "than the total number of terms on both sides."
say
say "If you want computer to try to solve this then enter"
say "the start and finish integers (1 <= min <= max <= 99)."
say "Enter just the minimum number for all coefficients if you prefer."
say "Or to do it yourself, hit return and re-enter the"
say "equation with 2 or more coefficients."
say
pull response
/* trace ?r */
if response = "" then signal restart
  else do /**/
    looking_for_nonregular_solutions = true
    select
      when words(response)=1 then
        do /***/
         /* trace ?r */
         strip_response = word(response,1)
         if datatype(strip_response)='NUM' then
            do /****/
             if strip_response>0 & strip_response<100 then
                do
                  $max = strip_response
                  $min = 1
                end
               else
                 do $max = 30; $min = 1; break; end
            end /****/
          else
            do $max = 30; $min = 1; break; end
        end /***/
      when words(response)=1 | words(response)=2 then
        do /* smile */
          response1 = word(response,1)
          response2 = word(response,2)
          if datatype(response1)='NUM' then do /*+*/
            if datatype(response2)='NUM' then
              select
                  when response1>0 & response1<100 then
                  do
                    $min = response1
                    if response2>=response1 & response2<100 then
                        $max = response2
                      else $max = $min + 30
                  end
                otherwise
                 do $min = 1; $max = 30; break; end
               end /* select */
             else
               do $min = 1; $max = 30; break; end
          end /*+*/
        end /* smile */
      otherwise do $min = 1; $max = 30; break; end
    end /* select */
  end /**/
call find_nonregular_solutions($min,$max)
looking_for_nonregular_solutions = false
signal restart
return

/*************************************************************/
/*   calculate1    calculate1    calculate1    calculate1    */
/*************************************************************/


calculate1:

/*  trace ?r */


if errortesting then say "entering 'calculate1'"

xx.1 = trunc(1.0*coef.row.1.column.2)
xx.2 = trunc(1.0*coef.row.1.column.1)

return /* from: calculate1 */




/*************************************************************/
/*   calculate     calculate     calculate     calculate     */
/*************************************************************/


calculate: /*procedure expose coef. xx. errortesting true false*/

/*  trace ?r */

#eqs_needed = arg(1)


say "entering calculate" #eqs_needed

  coeff = ""
  do i=1 to #eqs_needed
    do j=1 to #eqs_needed
      coeff = coeff||coef.row.i.column.j||" "
    end
  end

detmnt = trunc(det(#eqs_needed,coeff))
interpret "detmnt"#eqs_needed "= detmnt"

if errortesting then say "det = " detmnt

do j=1 to #eqs_needed
    #eqs_plus = #eqs_needed + 1
    const.j = coef.row.j.column.#eqs_plus
end

if detmnt=0 then do /**/
         call det_err_msg()
         signal jump
  end /**/
  else do
/*       coeff = ""
       do i=1 to #eqs_needed
          do j=1 to #eqs_needed
            coeff = coeff||m.row.i.column.j||" "
          end
        end */
        do i=1 to #eqs_needed
          coefficient = coeff
          do j=1 to #eqs_needed
            coefficient=,
              replace(const.j,coefficient,(j-1)*#eqs_needed+i)
          end
          xx.i = trunc(det(#eqs_needed,coefficient))
       end
jump:
return /* from: calculate */






/*************************************************************/
/*  det_err_msg   det_err_msg   det_err_msg   det_err_msg    */
/*************************************************************/

det_err_msg:

/* trace ?r */

     say "We have encountered a 'det = 0' problem."
     say "We'll try cyclic permuting of the elements_list."
     cycle_count = cycle_count + 1
     if cycle_count > #total_terms-1 then do
           say " Sorry, permutation failed."
           say " It could be that this equation will",
             "not balance."
           if doing_negative_values then do
               say "Try assigning different coefficients."
               say " "
               end
             else signal decide_on_nonregular
           signal restart
         end
       else do /*....*/
         parse var elements_list  first_term elements_list
         elements_list = elements_list||" "||first_term
         say " "
         say elements_list
         say
         original_elements_list = elements_list
         call calculate_answer
       end /*....*/
return


/*************************************************************/
/*      det      det      det      det      det      det     */
/*************************************************************/

det: procedure

/*  trace ?r */
size = arg(1)
str_of_coefs = arg(2)
/*say "det " arg(1)*/

do i=1 to size
  do j=1 to size
    coef.row.i.column.j = word(str_of_coefs,(i-1)*size+j)
  end
end

if size=2 then do
  A = coef.row.1.column.1*coef.row.2.column.2
  B = coef.row.1.column.2*coef.row.2.column.1
  return A - B
end

/* Here we setup to expand by minors. */
/*  trace ?r */
if size>=3 then do
    /* The next sections determine which row has the most*/
        /* zeros on it. */
    do i=1 to size
      count.i = 0
      do j=1 to size
        if coef.row.i.column.j=0 then
           count.i = count.i + 1
      end
    end
    index_most_zeros_so_far = 1
    do i=2 to size
      if count.i>count.index_most_zeros_so_far
        then index_most_zeros_so_far = i
    end
    expansion_row = index_most_zeros_so_far
    end
  else expansion_row = 1

do nullcolumn=1 to size /**/
  pivot=coef.row.expansion_row.column.nullcolumn
  if pivot~=0 then do
    do i=1 to size-1 /***/
      if i<expansion_row then row# = i
            else row# = i+1
      do j=1 to size-1 /****/
        if j < nullcolumn then col# = j
            else col# = j+1
        m.row.i.col.j=coef.row.row#.column.col#
      end /****/
    end /***/
   /*  trace  ?r */
    minor = ""
    do i=1 to size-1
      do j=1 to size-1
        minor = minor||m.row.i.col.j||" "
      end
    end
    term.nullcolumn=(-1.0)**(nullcolumn+expansion_row),
                      *pivot*det(size-1,minor)
  end
  else
    term.nullcolumn=0
end /**/
ans = 0
do i=1 to size
  ans = ans + term.i
end
return ans






/*************************************************************/
/*       print_answer      print_answer      print_answer    */
/*************************************************************/

print_answer:

if errortesting then say "entering 'print_answer'"

/*  trace ?r */

det# = arg(1)
if #Lterms+#Rterms >= 7 then two_lines_output=true
    else two_lines_output=false
answer = ""
do q=1 to #total_terms /**/
    select
      when q = #LH_terms then post = " = "
      when q = #total_terms then post = ""
      otherwise post = " + "
    end
    if q <= #LH_terms then do
        p = q
        @_side = LHS
        end
     else do
        p = q - #LH_terms
        @_side = RHS
     end
     if #total_terms = 2 then
           max_count = #total_terms
       else
           max_count = #total_terms - 1
     if (q <= max_count) then
       if doing_negative_values then do /***/
        /*  trace ?r  */
         select
           when q<=#LH_terms then
             best_term = word(newequation,q)
           when q>#LH_terms & q<=#total_terms then do
             adjustment = #originally_on_left - #LH_terms
             best_term = word(newequation,q+adjustment)
             end
           otherwise
             best_term = word(@_side,p)
         end /* select */
         if (abs(xx.q)=1) then
             answer = answer || best_term || post
           else
              answer = answer||abs(xx.q)||best_term||post
         end /***/
       else do
         /* trace ?r */
          if (abs(xx.q)=1) then
             answer = answer || word(@_side,p) || post
           else
              answer = answer||abs(xx.q)||word(@_side,p)||post
        end
end /**/
/* trace ?r */
if det# >= 4 then det = value("detmnt"||det#)
  else
   if #equations_needed=1 then
      det = 1
    else
      det = detmnt

/* trace ?r */
if abs(det)=1 then
       answer = answer || word(RHS,#RH_terms)
   else
       answer = answer || abs(det) || word(RHS,#RH_terms)
if #LH_terms = 0 then answer = " = "||answer
say " "
say "Balanced equation (?) :    "
say
if ~two_lines_output then say answer
  else do
    parse var answer newL "=" newR
    say " "newL "= "
    say "      " newR
  end
say " "
say " "

/* Here we try to reduce the equation if possible */
do z=1 to 1
  xxx.1 = abs(xx.1)
  xxx.2 = abs(xx.2)
  select
    when #total_terms=2 then NOP
    when #total_terms=3 then do
      xxx.3 = abs(det)
      end
    when #total_terms=4 then do
      xxx.3 = abs(xx.3)
      xxx.4 = abs(det)
      end
    when #total_terms=5 then do
      xxx.3 = abs(xx.3)
      xxx.4 = abs(xx.4)
      xxx.5 = abs(det)
      end
    otherwise do
        do m=3 to #total_terms-1
          xxx.m = abs(xx.m)
        end
        xxx.#total_terms = abs(det)
      end
  end /* select */


  @min_value = min_value()
  call reduce_eq(@min_value)

  answer = ""
  max_count = #total_terms /* - 1 */
  do q=1 to max_count
      select
        when q = #LH_terms then post = " = "
        when q = max_count then post = ""
        otherwise post = " + "
      end
      if q <= #LH_terms then do
          p = q
          @_side = LHS!
          end
       else do
          p = q - #LH_terms
          @_side = RHS!
       end
       if doing_negative_values then do /***/
         select
           when q<=#LH_terms then
             best_term = word(newequation,q)
           when q>#LH_terms & q<#total_terms then do
             adjustment = #originally_on_left - #LH_terms
             best_term = word(newequation,q+adjustment)
             end
           otherwise
             best_term = word(@_side,p)
         end /* select */
         if xxx.q=1 then
             answer = answer || best_term || post
           else
              answer = answer||xxx.q||best_term||post
         end /***/
       else
         if xxx.q=1 then
             answer = answer || word(@_side,p) || post
           else
             answer = answer || xxx.q || word(@_side,p) || post
  end
  if #LH_terms=0 then answer = " = "||answer
  say
  say "Reduced equation (?) :    "
  say
   if ~two_lines_output then say " " answer
    else do
      parse var answer newL "=" newR
      say " "newL "= "
      say "      " newR
    end
  say
  say
/*  trace ?r */
  if looking_for_nonregular_solutions then
      signal verify_solution
end

return /* from: print_answer */



/*************************************************************/
/*   reduce_eq     reduce_eq     reduce_eq     reduce_eq     */
/*************************************************************/


reduce_eq: procedure expose xxx. #total_terms true false errortesting

/* trace ?r */


if errortesting then say "Entering `reduce_eq'"

min_value = arg(1)
/* say "min_value = " min_value */
do n=1 to min_value /**/
  if errortesting then say "  n = " n
  i = 1
  do while i <= min_value/2+1
 /***/
    matchfailed = false
    i = i + 1
    if errortesting then      say "     i = " i
    do j=1 to #total_terms while ~matchfailed
      if i * trunc(1.0*(xxx.j/i))~=xxx.j then matchfailed = true
    end
    if ~matchfailed then
      do k=1 to #total_terms /****/
          xxx.k = xxx.k/i
      end /****/
  end /***/
end /**/
return /* from: reduce_eq */


/*************************************************************/
/*     min_value    min_value     min_value     min_value    */
/*************************************************************/

min_value:

if errortesting then say "Entering 'min_value'"

/*  trace ?r  */

select
   when #total_terms=2 then
       min_val = min(xxx.1,xxx.2)
   when #total_terms=3 then
       min_val = min(xxx.1,xxx.2,xxx.3)
   when #total_terms=4 then
       min_val = min(xxx.1,xxx.2,xxx.3,xxx.4)
   when #total_terms=5 then
       min_val = min(xxx.1,xxx.2,xxx.3,xxx.4,xxx.5)
   when #total_terms=6 then
       min_val = min(xxx.1,xxx.2,xxx.3,xxx.4,xxx.5,xxx.6)
   when #total_terms=7 then
       min_val = min(xxx.1,xxx.2,xxx.3,xxx.4,xxx.5,xxx.6,xxx.7)
   when #total_terms=8 then do
        /* trace ?r */
       min_val =,
         min(xxx.1,xxx.2,xxx.3,xxx.4,xxx.5,xxx.6,xxx.7,xxx.8)
       end
   when #total_terms=9 then
     min_val =,
      min(xxx.1,xxx.2,xxx.3,xxx.4,xxx.5,xxx.6,xxx.7,xxx.8,xxx.9)
  when #total_terms=10 then
     min_val=min(xxx.1,xxx.2,,
        xxx.3,xxx.4,xxx.5,xxx.6,xxx.7,xxx.8,xxx.9,xxx.10)
 when #total_terms=20 then do
     min_val1 = min(xxx.1,xxx.2,xxx.3,xxx.4,xxx.5)
     min_val2 = min(xxx.6,xxx.7,xxx.8,xxx.9,xxx.10)
     min_val3 = min(xxx.11,xxx.12,xxx.13,xxx.14,xxx.15)
     min_val4 = min(xxx.16,xxx.17,xxx.18,xxx.19,xxx.20)
     min_val = min(min_val1,min_val2,min_val3,min_val4)
     end
   otherwise do
      say "Sorry, only nine terms max for input!"
      signal restart
   end
end

return min_val



/*************************************************************/
/*    #elements_side     #elements_side     #elements_side   */
/*************************************************************/



#elements_side:

if errortesting then say "Entering #elements_side."

/*  trace ?r */

side# = arg(1)

if side# = 1 then #terms = words(LHS)
    else #terms = words(RHS)
sum = 0
do ii=1 to #terms /**/
  more_elements_in_term = true
  jj = 1
  do while more_elements_in_term /***/
    if side.side#.term_pos.ii.element.jj=currentelement then do
      if side#=1 then kk = ii
           else kk = ii + words(LHS)
      sum = sum+side.side#.term_pos.ii.element.jj.count*(xxx.kk)
    end
    jj = jj + 1
    if side.side#.term_pos.ii.element.jj = "NIL" then
         more_elements_in_term = false
  end /***/
end /**/
if errortesting then do
  say
  say "sum = " sum " for " currentelement
end
return sum /* from: #elements_side */



/*************************************************************/
/*          verify_solution          verify_solution         */
/*************************************************************/



verify_solution:

if errortesting then say "Entering verify_solution."

matchfailed = false

/*  trace ?r */
/* call print_original_equation */
if ~doing_negative_values then
  if ~looking_for_nonregular_solutions then
     elements_list=original_elements_list
#elements = words(elements_list)
if errortesting then say "element list = " elements_list

zero_found = false /* zero coefficient */
do z=1 to #elements while ~zero_found
  if xxx.z=0 then do
    zero_found = true
    matchfailed = true
  end
end

if ~matchfailed then
  do i=1 to #elements  while ~matchfailed
    currentelement = word(elements_list,i)
    if #elements_side(1)~=#elements_side(2) then
        matchfailed = true
  end
if ~matchfailed then do
      say "Solution is verified."
      say
      say
      if doing_negative_values then call print_original_equation
      end
   else do
     if looking_for_nonregular_solutions then
       do
         /* trace ?r */
         if doing_for_three then signal return_to_loop_for_three
           else  signal return_to_loop_for_two
       end
     say "Verifying solution:"
     say
     say "Sorry! Verification FAILED!"

     say "Solution above failed for element '"currentelement"'."
     if ~doing_negative_values then do
        say "Your original equation cannot be balanced!!"
        say

        end
      else do
        say
        say "  Your original equation either cannot be balanced"
        say "    with the coefficients you chose or "
        say "      you have unbalanced elements!!"
        say
        end
   end
return /* from: verify_solution */



/*************************************************************/
/*     rightmostchar     rightmostchar      rightmostchar    */
/*************************************************************/

rightmostchar:

if pos(right(arg(1),1),arg(2)) > 0 then return 1
else return 0



/*************************************************************/
/*      all_but_rightmostchar      all_but_rightmostchar     */
/*************************************************************/

all_but_rightmostchar:

return left(arg(1),length(arg(1))-1)



/*************************************************************/
/*      stripped     stripped     stripped     stripped      */
/*************************************************************/

stripped: procedure expose true false

string = arg(1)

indigits = xrange("0","9")
more_digits_to_do = true
do while string~="" & more_digits_to_do
  if firstchar(string,indigits) then
    string = allbutleftchar(string)
  else
    more_digits_to_do = false
end

return string




/*************************************************************/
/*     print_original_equation   print_original_equation     */
/*************************************************************/



print_original_equation:

if errortesting then say "Entering print_original_equation."
/*  trace ?r */

if errortesting then say "newequation = " newequation
#original_total_terms = #originally_on_left+#originally_on_right
coef_removed = false
indigits = xrange("0","9")
parens_exist = (pos("(",answer)>0)
if #equations_needed=1 then
     last_coef = xxx.2
  else
     last_coef = xxx.#total_terms /* of the revised equation */

if pos("=",answer)=0 then do
  LHS = ""
  RHS = answer
  end
else
  parse var answer LHS "=" RHS
if errortesting then
  say "#originally_on_left = " #originally_on_left
i = 1
do while (UDcoef.i~=0) && (i<=#originally_on_left+1)
  i = i + 1
end
if pos("[",RHS) > 0 then morebrackets = true
  else morebrackets = false
do while morebrackets
  parse var RHS RHS "["termtomove "]_"ultraright
  if ~parens_exist then
    if ~ coef_removed then do
      do while rightmostchar(RHS,indigits)
         RHS = all_but_rightmostchar(RHS)
      end
      coef_removed = true
    end
  coef = last_coef*subscr(ultraright)
  if coef = 1 then coef = ""
  if compress(LHS)="" then do
    LHS = coef||word(newequation,i)
    i = i + 1
    end
  else do
    LHS = LHS||" + "||coef||word(newequation,i)
    i = i + 1
    end
  if pos("[",ultraright) = 0 then
    morebrackets = false
  RHS = RHS||ultraright
end

i = #originally_on_left + 1
do while UDcoef.i~=0 && i<=#original_total_terms
  i = i + 1
end
if pos("(",RHS) > 0 then moreparens = true
  else moreparens=false
counttimesthru = 0
do while moreparens
  parse var RHS RHS "("termtofix ")_"ultraright
  if parens_exist then
    If ~coef_removed then do
      do while rightmostchar(RHS,indigits)
         RHS = all_but_rightmostchar(RHS)
      end
      coef_removed = true
    end
  counttimesthru = counttimesthru + 1
  coef = last_coef*subscr(ultraright)
  if coef = 1 then coef = ""
  select
    when counttimesthru=1 then do
       RHS = RHS||coef||word(newequation,i)||ultraright
       i = i + 1
       end
    otherwise do
      RHS = RHS||" + "||coef||word(newequation,i)||ultraright
      i = i + 1
      end
  end /* select */
  if pos("(",ultraright)  = 0 then
    moreparens = false
end

if counttimesthru = 0 then
  do while rightmostchar(RHS,'+') | rightmostchar(RHS," ")
     RHS = all_but_rightmostchar(RHS)
  end

say "Penultimate equation..."
say
say "  " LHS||" = "||RHS
say
if doing_negative_values | looking_for_nonregular_solutions then
   call print_in_original_order()

return /* from: print_original_equation */


print_in_original_order:
previous_eq = LHS||" "||RHS
call drop_plusses()
call strip_previous_eq()
do k=1 to words(stripped_previous_eq)
  stripped_term.k = word(stripped_previous_eq,k)
end
call setup_final_equation()
say "Last equation (I promise!)..."
/*  trace ?r */
final_LHS=term.1
first_Rterm# = #Lterms+1
final_RHS = " = "||term.first_Rterm#
do i=2 to #Lterms
  final_LHS=final_LHS||" + "term.i
end

do i=#Lterms+2 to #total_words
  final_RHS=final_RHS||" + "term.i
end
say
if #Lterms+#Rterms>=7 then say "   " final_LHS||final_RHS
  else do
    say " " final_LHS
    say "    " final_RHS
    end
say
if looking_for_nonregular_solutions then do
  call writeln(outputfile,final_LHS||final_RHS)
  call writeln(outputfile," ")
  if doing_for_two then
    signal return_to_loop_for_two
   else
    signal return_to_loop_for_three
end
return


drop_plusses:
if pos("+",previous_eq)>0 then do
  parse var previous_eq leftstuff "+" rightstuff
  previous_eq = leftstuff||rightstuff
  call drop_plusses
end
return


strip_previous_eq:
eq=" "||previous_eq
do_once_again:
do i=2 to length(eq)
  position=pos(char(eq,i),digits)
  if position>0 & pos(char(eq,i-1)," ")>0 then do
    eq=delstr(eq,i,1)
    signal do_once_again
    end
end
stripped_previous_eq=eq
return

setup_final_equation:
/* trace ?r */
#words_previous_eq = words(stripped_previous_eq)
#total_words=words(original_stripped_eq)
do i=1 to #total_words
  match_found = false
  do j=1 to #words_previous_eq while ~match_found
    if word(original_stripped_eq,i)=stripped_term.j,
      then do
        term.i = word(previous_eq,j)
        match_found = true
      end
  end
end

return


/*************************************************************/
/*     subscr      subscr    subscr     subscr    subscr     */
/*************************************************************/



subscr:

if errortesting then say "Entering subscr"
/*  trace ?r  */

rightstuff = arg(1)
factor = ""
do while pos(left(rightstuff,1),xrange("0","9"))>0
  factor = factor||left(rightstuff,1)
  rightstuff = right(rightstuff,length(rightstuff)-1)
end
/* if factor="" then factor = 1 */
ultraright = rightstuff

return factor

/*************************************************************/
/*                                                           */
/*      `Nonregular' Functions    `Nonregular' Functions     */
/*                                                           */
/*************************************************************/

find_nonregular_solutions:

/* Nonregular functions are functions that are used to find nonregular solutions, which are solutions that are not unique for
a given unbalanced equation. These solutions are placed in the file `ram:solutions'. */

/*  trace ?r */

if errortesting then say "Entering `find_nonregular_solutions'"

looking_for_nonregular_solutions = true
bare_eq = LHS!||" "||RHS!
total#terms = words(bare_eq)
original_eq = unequation
outputfile = 'outputfile'
call open(outputfile,"ram:solutions",'w')

do indexx=1 to #elements
  curr_el = word(elements_list,indexx)
  say "elements_list = " elements_list
  say "Current element = " curr_el
  say
  N = #term_with_element(curr_el)
  select
    when N=3 then
      do
        call do_for_three(curr_el)
        say "Move to next element:"
        say
        /* trace ?r */
      end
    when N=2 then call do_for_two(curr_el)
    otherwise
      do
        say
        say "Element " curr_el "had term count > 3."
      end
  end /* select */
end
looking_for_nonregular_solutions = false
/* call close(outputfile) */
signal restart
return




#term_with_element: procedure expose total#terms bare_eq

cur_el = arg(1)
count = 0
do i=1 to total#terms
  if pos(cur_el,word(bare_eq,i))>0 then count = count + 1
end
return count



do_for_two:
/*
if errortesting then say "Entering `do_for_two'"

 trace ?r

doing_for_two   = true
doing_for_three = false

first  = term#with(curr_el,0)
second = term#with(curr_el,first)
el_found = false
do z=1 to #elements while ~el_found
  if side.1.term_pos.first.element.z=curr_el then do
      el_found = true
      V1 = side.1.term_pos.first.element.z.count
    end
end
$second = second-#Lterms
el_found = false
do z=1 to #elements while ~el_found
  if side.2.term_pos.$second.element.z=curr_el then
    do
      el_found = true
      V2 = side.2.term_pos.$second.element.z.count
    end
end
interpret "$string2 = " V2"||word(LHS!,first)"
interpret "$string1 = " V1"||word(RHS!,$second)"
newLHS = replace(" "||$string2,LHS!,first)
newRHS = replace(" "||$string1,RHS!,$second)
$unequation = newLHS||" = "||newRHS

signal begin_nonregular

return_to_loop_for_two:
*/
return




term#with: procedure expose bare_eq total#terms

el    = arg(1)
start = arg(2)+1
do i=start to total#terms
  if pos(el,word(bare_eq,i))>0 then return i
end




replace: procedure

new_word  = arg(1)
str       = arg(2)
position  = arg(3)
newstring = ""
len       = words(str)
do i=1 to position-1
  newstring = newstring||" "||word(str,i)
end
newstring = newstring||" "||new_word
do i=position+1 to len
  newstring = newstring||" "||word(str,i)
end
return newstring





do_for_three:

if errortesting then say "Entering `do_for_three'"
/* trace ?r */
current_el = arg(1)
call init_values()
/*  trace ?r */
rr = $min
return_to_loop_at_rr:
if rr<=$max then do /**/
call second_init_values()
 /*   trace ?r */
  ss = 1
  return_to_loop_at_ss:
  if ss<=$max then do /****/
    if ss*middlevalue<total_in_max_term then do /******/
        ch = char(word(order_by_quantity,1),2)
        select
          when ch = '1' then leastvalue = Q1
          when ch = '2' then leastvalue = Q2
          when ch = '3' then leastvalue = Q3
        end
        tt = 1
        return_to_loop_for_three:
        /* trace ?r */
        say rr ss tt
        call set_terms_for_both_sides()
        if tt<=$max then
          do
            if tt*leastvalue<total_in_max_term then
              do
                call $calc()
              end
            tt = tt + 1
            signal return_to_loop_for_three
          end
        else
          do
            ss = ss + 1
            signal return_to_loop_at_ss
          end
    end /******/
    ss = ss + 1
    signal return_to_loop_at_ss
  end /****/
  rr = rr + 1
  interpret "MAXV = " max_value$
  interpret "midval = " middlevalue
  interpret "leastval = " leastvalue
  if rr*MAXV <= $max*(midval+leastval) then
     signal return_to_loop_at_rr
   else return
end /**/
return




OBQ:

if Q1<=Q2 then
   do /**/
    if Q2<=Q3 then return "Q1 Q2 Q3"
     else
      do /***/
        if Q3<=Q1 then return "Q3 Q1 Q2"
           else return "Q1 Q3 Q2"
      end /***/
   end /**/
  else
   if Q3<=Q2 then return "Q3 Q2 Q1"
     else do
      if Q1<=Q3 then return "Q2 Q1 Q3"
         else return "Q2 Q3 Q1"
      end



Q: procedure expose side. #elements true false
$side = arg(1)
$term = arg(2)
$el   = arg(3)

el_found = false
do z=1 to #elements while ~el_found
  if side.$side.term_pos.$term.element.z=$el then
    do
      el_found = true
      return side.$side.term_pos.$term.element.z.count
    end
end
return



init_values:

/*  trace ?r */
doing_for_three = true
doing_for_two   = false

/*  trace ?r */
L_el_list =  elements_list.@side.1
R_el_list =  elements_list.@side.2
say "R_el_list = " R_el_list
say "L_el_list = " L_el_list
position_found = false
do ii=1 to #elements until position_found
  if word(L_el_list,ii)=current_el then do
      Rpos = ii
      position_found = true
  end
end

first  = term#with(current_el,0)
second = term#with(current_el,first)
third  = term#with(current_el,second)
/* trace ?r */
Q1     = Q(1,first,current_el)

if second<=#Lterms then do
    word#2 = second
    side#2 = 1
   end
  else do
    word#2 = second - #Lterms
    side#2 = 2
   end
Q2 = Q(side#2,word#2,current_el)
 $third = third-#Lterms
Q3 = Q(2,$third,current_el)
say Q1
say Q2
say Q3
/*  trace ?r */
order_by_quantity = OBQ()
interpret "max_value = " word(order_by_quantity,3)
select
  when word(order_by_quantity,3)='Q1' then max_value$ = 'Q1'
  when word(order_by_quantity,3)='Q2' then max_value$ = 'Q2'
  when word(order_by_quantity,3)='Q3' then max_value$ = 'Q3'
end
ch = char(word(order_by_quantity,3),2)
select
  when ch = '1' then largestterm = first
  when ch = '2' then largestterm = second
  when ch = '3' then largestterm = third
end
ch = char(word(order_by_quantity,2),2)
select
  when ch = '1' then middleterm = first
  when ch = '2' then middleterm = second
  when ch = '3' then middleterm = third
end
ch = char(word(order_by_quantity,1),2)
select
  when ch = '1' then smallestterm = first
  when ch = '2' then smallestterm = second
  when ch = '3' then smallestterm = third
end
return



second_init_values:

  select
    when char(max_value$,2)='1' then
        total_in_max_term = rr*Q1
    when char(max_value$,2)='2' then
        total_in_max_term = rr*Q2
    when char(max_value$,2)='3' then
        total_in_max_term = rr*Q3
  end
  ch = char(word(order_by_quantity,2),2)
  select
    when ch = '1' then middlevalue = Q1
    when ch = '2' then middlevalue = Q2
    when ch = '3' then middlevalue = Q3
  end
return


set_terms_for_both_sides:
interpret "$Num0 = " rr||"11"
interpret "$Num = " rr||ss||tt
   if  $Num0=$Num then
     do
      $originalR = RHS!
      $originalL = LHS!
      $elements_list = R_el_list
     end
    else
      do
        /*  trace ?r */
        RHS! = $originalR
        LHS! = $originalL
        elements_list = $elements_list
      end
return




$calc:
/* trace ?r */
if balances_for_curr_el() then
  do /**/
    adjusted_LHS = false
    adjusted_RHS = false
    call set_largest_term(largestterm)
    call set_middle_term(middleterm)
    call set_smallest_term(smallestterm)
    /* trace ?r */
    $unequation = newLHS||" = "||newRHS
    tt = tt + 1
    signal begin_nonregular
  end /**/
return




set_largest_term:
place = arg(1)
if adjusted_LHS then $LHS = newLHS
    else $LHS = LHS!
if adjusted_RHS then $RHS = newRHS
    else $RHS = RHS!

ch = char(word(order_by_quantity,3),2)
select
  when ch = '2' then
     if side#2=1 then do
        newLHS =  replace(rr||word($LHS,place),$LHS,place)
        adjusted_LHS = true; end
      else do
        $place = place-#Lterms
        newRHS =,
         replace(rr||word($RHS,$place),$RHS,$place)
        adjusted_RHS = true; end
  when ch = '1' then do
      newLHS = replace(rr||word($LHS,place),$LHS,place)
      adjusted_LHS = true; end
  when ch = '3' then do
      $place = place-#Lterms
      newRHS =,
        replace(rr||word($RHS,$place),$RHS,$place)
        adjusted_RHS = true; end
end
return





set_middle_term:
place = arg(1)
if adjusted_LHS then $LHS = newLHS
    else $LHS = LHS!
if adjusted_RHS then $RHS = newRHS
    else $RHS = RHS!

ch = char(word(order_by_quantity,2),2)
select
  when ch = '2' then
     if side#2=1 then do
        newLHS =  replace(ss||word($LHS,place),$LHS,place)
        adjusted_LHS = true; end
      else do
        $place = place-#Lterms
        newRHS =,
         replace(ss||word($RHS,$place),$RHS,$place)
        adjusted_RHS = true; end
  when ch = '1' then do
      newLHS = replace(ss||word($LHS,place),$LHS,place)
      adjusted_LHS = true; end
  when ch = '3' then do
      $place = place-#Lterms
      newRHS =,
        replace(ss||word($RHS,$place),$RHS,$place)
        adjusted_RHS = true; end
end
return





set_smallest_term:
place = arg(1)
if adjusted_LHS then $LHS = newLHS
    else $LHS = LHS!
if adjusted_RHS then $RHS = newRHS
    else $RHS = RHS!

ch = char(word(order_by_quantity,1),2)
select
  when ch = '2' then
     if side#2=1 then do
        newLHS =  replace(tt||word($LHS,place),$LHS,place)
        adjusted_LHS = true; end
      else do
        $place = place-#Lterms
        newRHS =,
         replace(tt||word($RHS,$place),$RHS,$place)
        adjusted_RHS = true; end
  when ch = '1' then do
      newLHS = replace(tt||word($LHS,place),$LHS,place)
      adjusted_LHS = true; end
  when ch = '3' then do
      $place = place-#Lterms
      newRHS =,
        replace(tt||word($RHS,$place),$RHS,$place)
        adjusted_RHS = true; end
end
return




balances_for_curr_el:

/* Here we test to see if the coefficients chose will at least balance that particular element before trying to ttest balance the entire equation. */


do a=1 to 3
  ch.a = char(word(order_by_quantity,a),2)
end
select
  when ch.3='1' then do /**/
    if side#2=1 then
      do /***/
        if ch.2='2' then
          do
            if total_in_max_term+ss*middlevalue=tt*leastvalue
              then return true
              else return false
          end
        else
          do
            if total_in_max_term+tt*leastvalue=ss*middlevalue
              then return true
              else return false
          end
      end /***/
    else
      do
        if total_in_max_term=tt*leastvalue+ss*middlevalue
            then return true
            else return false
      end
  end /**/

  when ch.3='2' then do /**/
    if side#2=1 then
      do /***/
        if ch.1='1' then
          do
            if tt*leastvalue+total_in_max_term=ss*middlevalue
              then return true
              else return false
          end
        else
          do
            if ss*middlevalue+total_in_max_term=tt*leastvalue
              then return true
              else return false
          end
      end /***/
    else
      do
        if ch.1='1' then
          do
            if tt*leastvalue=total_in_max_term+ss*middlevalue
              then return true
              else return false
          end
        else
            if ss*middlevalue=total_in_max_term+tt*leastvalue
              then return true
              else return false
      end
  end /**/


  when ch.3='3' then do /**/
    if side#2=1 then
       do
        if ss*middlevalue+tt*leastvalue=total_in_max_term
            then return true
            else return false
       end
     else
       do
         if ch.2='1' then
            do
             if ss*middlevalue=tt*leastvalue+total_in_max_term
               then return true
               else return false
            end
          else
            do
             if tt*leastvalue=ss*middlevalue+total_in_max_term
               then return true
               else return false
            end
       end
    end /**/
end /* select */