'***************************************************************************
'*                  Symbolic Parser with Polynomials                       *
'*                 Example : "(A+B)^2" ==> A^2+2AB+B^2                     *
'*            English BASIC version 2.21 By J-P Moreau, Paris              *
'*                           (www.jpmoreau.fr)                             *
'* ----------------------------------------------------------------------- *
'*      Release 2.0: program improvement to take care of two digits        *
'*                   exponants.                                            *
'*      Release 2.1: (A+B)(C+D) ==> (A+B)*(C+D)                            *
'*                    25(C-3D)  ==>  25*(C-3D)                             *
'*      Release 2.2: 1. Some procedures are transformed into               *
'*                   functions to return an index value, in case of        *
'*                   table overflows ( SIMPLI, PARE, PUIS, COPIE,          *
'*                   IMPR ), that allows stopping the computing            *
'*                   without crashing the program.                         *
'*                   2. Possibility to read the input string from          *
'*                   a text file.                                          *
'*     Release 2.21: Minor corrections (Display CH$ > 70 characters        *
'*                   and bug in IMPR, line 392).                           *
'* ----------------------------------------------------------------------- *
'* SAMPLE RUN:                                                             *
'*                                                                         *
'*                   SYMBOLIC PARSER FOR POLYNOMIALS                       *
'*                                                                         *
'*                   Example: (A+B)^2 ==> A^2+2AB+B^2                      *
'*                                                                         *
'* Inputs (0=SCREEN  1=algebra.dat file): 0                                *
'* Input string to evaluate:                                               *
'* (A+B+C)^3                                                               *
'*                                                                         *
'* Detail analysis (0=NO  1=YES): 1                                        *
'* Outputs (0=SCREEN  1=algebra.lst file): 0                               *
'*                                                                         *
'* SIMPLIFICATION:                                                         *
'* (A+B+C)^3                                                               *
'* POWER:                                                                  *
'* (A^3+3A^2B+3A^2C+3AB^2+6ABC+3AC^2+B^3+3B^2C+3BC^2+C^3)                  *
'* ADDITION:                                                               *
'* A^3+3A^2B+3A^2C+3AB^2+6ABC+3AC^2+B^3+3B^2C+3BC^2+C^3                    *
'*                                                                         *
'* FINAL SIMPLIFICATION AND RESULT:                                        *
'*                                                                         *
'* A^3+3A^2B+3A^2C+3AB^2+6ABC+3AC^2+B^3+3B^2C+3BC^2+C^3                    *
'*                                                                         *
'* Evaluate another string (0=NO  1=YES): 1                                *
'*                                                                         *
'* (Assuming the input file algabra.dat contains the line:                 *
'* (A+B+C+D)^4+(A+B+C-D)^4 )                                               *
'*                                                                         *
'* Inputs (0=SCREEN  1=algebra.dat file): 1                                *
'* Input string to evaluate:                                               *
'* (A+B+C+D)^4+(A+B+C-D)^4                                                 *
'*                                                                         *
'* Detail analysis (0=NO  1=YES): 1                                        *
'* Outputs (0=SCREEN  1=algebra.lst file): 1                               *
'*                                                                         *
'* The file algebra.lst contains:                                          *
'*                                                                         *
'* STRING TO EVALUATE:                                                     *
'*  (A+B+C+D)^4+(A+B+C-D)^4                                                *
'*                                                                         *
'* SIMPLIFICATION:                                                         *
'*  (A+B+C+D)^4+(A+B+C-D)^4                                                *
'* POWER:                                                                  *
'*  (A^4+4A^3B+4A^3C+4A^3D+6A^2B^2+12A^2BC+12A^2BD+6A^2C^2+12A^2CD+6A^2D^2 *
'*  +4AB^3+12AB^2C+12AB^2D+12ABC^2+24ABCD+12ABD^2+4AC^3+12AC^2D+12ACD^2+4A *
'*  D^3+B^4+4B^3C+4B^3D+6B^2C^2+12B^2CD+6B^2D^2+4BC^3+12BC^2D+12BCD^2+4BD^ *
'*  3+C^4+4C^3D+6C^2D^2+4CD^3+D^4)+(A+B+C-D)^4                             *
'* ADDITION:                                                               *
'*  A^4+4A^3B+4A^3C+4A^3D+6A^2B^2+12A^2BC+12A^2BD+6A^2C^2+12A^2CD+6A^2D^2+ *
'*  4AB^3+12AB^2C+12AB^2D+12ABC^2+24ABCD+12ABD^2+4AC^3+12AC^2D+12ACD^2+4AD *
'*  ^3+B^4+4B^3C+4B^3D+6B^2C^2+12B^2CD+6B^2D^2+4BC^3+12BC^2D+12BCD^2+4BD^3 *
'*  +C^4+4C^3D+6C^2D^2+4CD^3+D^4+(A+B+C-D)^4                               *
'* POWER:                                                                  *
'*  A^4+4A^3B+4A^3C+4A^3D+6A^2B^2+12A^2BC+12A^2BD+6A^2C^2+12A^2CD+6A^2D^2+ *
'*  4AB^3+12AB^2C+12AB^2D+12ABC^2+24ABCD+12ABD^2+4AC^3+12AC^2D+12ACD^2+4AD *
'*  ^3+B^4+4B^3C+4B^3D+6B^2C^2+12B^2CD+6B^2D^2+4BC^3+12BC^2D+12BCD^2+4BD^3 *
'*  +C^4+4C^3D+6C^2D^2+4CD^3+D^4+(A^4+4A^3B+4A^3C-4A^3D+6A^2B^2+12A^2BC-12 *
'*  A^2BD+6A^2C^2-12A^2CD+6A^2D^2+4AB^3+12AB^2C-12AB^2D+12ABC^2-24ABCD+12A *
'*  BD^2+4AC^3-12AC^2D+12ACD^2-4AD^3+B^4+4B^3C-4B^3D+6B^2C^2-12B^2CD+6B^2D *
'*  ^2+4BC^3-12BC^2D+12BCD^2-4BD^3+C^4-4C^3D+6C^2D^2-4CD^3+D^4)            *
'* ADDITION:                                                               *
'*  A^4+4A^3B+4A^3C+4A^3D+6A^2B^2+12A^2BC+12A^2BD+6A^2C^2+12A^2CD+6A^2D^2+ *
'*  4AB^3+12AB^2C+12AB^2D+12ABC^2+24ABCD+12ABD^2+4AC^3+12AC^2D+12ACD^2+4AD *
'*  ^3+B^4+4B^3C+4B^3D+6B^2C^2+12B^2CD+6B^2D^2+4BC^3+12BC^2D+12BCD^2+4BD^3 *
'*  +C^4+4C^3D+6C^2D^2+4CD^3+D^4+A^4+4A^3B+4A^3C-4A^3D+6A^2B^2+12A^2BC-12A *
'*  ^2BD+6A^2C^2-12A^2CD+6A^2D^2+4AB^3+12AB^2C-12AB^2D+12ABC^2-24ABCD+12AB *
'*  D^2+4AC^3-12AC^2D+12ACD^2-4AD^3+B^4+4B^3C-4B^3D+6B^2C^2-12B^2CD+6B^2D^ *
'*  2+4BC^3-12BC^2D+12BCD^2-4BD^3+C^4-4C^3D+6C^2D^2-4CD^3+D^4              *
'*                                                                         *
'* FINAL SIMPLIFICATION AND RESULT:                                        *
'*                                                                         *
'*  2A^4+8A^3B+8A^3C+12A^2B^2+24A^2BC+12A^2C^2+12A^2D^2+8AB^3+24AB^2C+24AB *
'*  C^2+24ABD^2+8AC^3+24ACD^2+2B^4+8B^3C+12B^2C^2+12B^2D^2+8BC^3+24BCD^2+2 *
'*  C^4+12C^2D^2+2D^4                                                      *
'*                                                                         *
'* ----------------------------------------------------------------------- *
'* Reference: "Calcul symbolique et informatique. Du calcul numerique au   *
'*             calcul litteral (programmes en BASIC de A. DESHAYES),       *
'*             Masson Paris, 1985" [BIBLI02].                              *
'***************************************************************************
'PROGRAM ALGEBRA
DEFINT I-N

MaxSize = 270                               'maximum number of terms

'Labels in main: 110,130,220,250,290,300,340,350,370,460,470,480,
'                481,485,490,510,540,560,1000,1465,1470,1580,
'                8000,8050,8100

'Subroutines:
'                600    Look for a "£" or a "(" operator
'               1070    Simplify monoms (BAB ==> AB^2)                 
'               1100    Verify if N<=MaxSize
'               1200    Error message if Verif < > 0
'               1300    Simplify polynomial (2AB-AB ==> AB)
'               5000    Multiply parentheses ( (A+B)*C ==> AC+BC)
'               9000    Copy a simplified result into current result
'              10000    Print intermediate or final result
'              11000    Integer power of a polynomial
'              13000    Addition
'              13500    Substraction
'              20000    Derivative (not implemented here)

' Global variables:
' ----------------
'   CH$ : string to evaluate
'   RR$ : final answer
DIM ALFA$(26)    'table of variables A..Z
DIM CP$(MaxSize), R$(MaxSize), P$(MaxSize), SI$(MaxSize)
DIM T(MaxSize), P(MaxSize), R(MaxSize)
DIM E$(26), IE(26)
DIM CP(MaxSize), SI(MaxSize)
DIM IPI(MaxSize), IPO(MaxSize)
'   D$,EC$,IE$,T$,Y$,PR$,NB$,EN$,VL$,M$,M1$: Strings
'   I,IC,IC1,IE1,IEN,IEX,INB,ISI,IVL,LE1,NB,NC,NL,IRE: integers
'   IAP,IDI,IDM,IFM,IH,IHC,IHO,IHP,INO,IPF,IPP,JPO,LE: integers
'   I4,IDC,IMD,IMG,IO1,IR,ISL,KS,NS,IRF,IRT: integers
'   C$,SU$: chars
'   EC,EX,XM: reals
'   E1$: string
'   IOk: integer

      IRF = 0: CLS
      PRINT
      PRINT "                     SYMBOLIC PARSER FOR POLYNOMIALS"
      PRINT
      PRINT "                     Example:  (A+B)^2 ==> A^2+2AB+B^2"
      PRINT
      FOR I = 1 TO 26
        ALFA$(I) = CHR$(I + 64)
      NEXT I
110   IF IRF = 1 THEN
        CLS
        PRINT
      END IF
      PRINT "  Inputs (0=SCREEN  1=algebra.dat file): "; : INPUT "", IRT
      IF IRT = 0 THEN
        PRINT "  Input string to evaluate: "
        INPUT "  ", CH$
        PRINT
      ELSE
        OPEN "algebra.dat" FOR INPUT AS #1
        INPUT #1, CH$
        CLOSE #1
        PRINT "  String to evaluate: "
        IC = LEN(CH$)
        IF IC < 71 THEN
          PRINT "  "; CH$
        ELSEIF IC < 141 THEN
          PRINT "  "; LEFT$(CH$, 70)
          PRINT "  "; RIGHT$(CH$, IC - 70)
        ELSEIF IC < 211 THEN
          PRINT "  "; LEFT$(CH$, 70)
          PRINT "  "; MID$(CH$, 71, 70)
          PRINT "  "; RIGHT$(CH$, IC - 140)
        END IF
        PRINT
      END IF
      PRINT "  Detail Analysis (0=NO  1=YES): "; : INPUT "", IRE
      PRINT "  Outputs (0=SCREEN  1=algebra.lst file): "; : INPUT "", IRT
      IF IRT = 0 THEN PRINT
      IF IRT = 1 THEN
        OPEN "algebra.lst" FOR OUTPUT AS #2
        PRINT #2, ""
        PRINT #2, "  STRING TO EVALUATE:"
        IC = LEN(CH$)
        IF IC < 71 THEN
          PRINT #2, "  "; CH$
        ELSEIF IC < 141 THEN
          PRINT #2, "  "; LEFT$(CH$, 70)
          PRINT #2, "  "; RIGHT$(CH$, IC - 70)
        ELSEIF IC < 211 THEN
          PRINT #2, "  "; LEFT$(CH$, 70)
          PRINT #2, "  "; MID$(CH$, 71, 70)
          PRINT #2, "  "; RIGHT$(CH$, IC - 140)
        END IF
        PRINT #2, ""
      END IF

'     preliminary loop to add a * sign between
'     two parentheses )( or a digit and (.
      FOR IC = 1 TO LEN(CH$)
        C$ = MID$(CH$, IC, 1)
        IF C$ = ")" AND MID$(CH$, IC + 1, 1) = "(" THEN
          CH$ = LEFT$(CH$, IC) + "*" + RIGHT$(CH$, LEN(CH$) - IC)
        END IF
        IF C$ >= "0" AND C$ <= "9" AND MID$(CH$, IC + 1, 1) = "(" THEN
          CH$ = LEFT$(CH$, IC) + "*" + RIGHT$(CH$, LEN(CH$) - IC)
        END IF
      NEXT IC
     
      IC = 1
      C$ = MID$(CH$, IC, 1)
      NC = 0

      GOSUB 600   'call OPERA(CH$,IC,C$,NC,D$)
     
'     string analysis main loop
'     -------------------------
130   IF IC > LEN(CH$) THEN GOTO 1000
      IF C$ = "-" THEN ISI = -1 ELSE ISI = 1
      IF C$ = "+" OR C$ = "-" THEN
        IC = IC + 1
        C$ = MID$(CH$, IC, 1)
      END IF
      IF C$ = "(" THEN GOTO 220
      IF C$ <> "œ" THEN GOTO 250
      'opening parenthesis
220   PR$ = MID$(CH$, IC - 1, 1)
      NC = NC + 1
      CP$(NC) = PR$

      GOSUB 600 'call OPERA(CH$,IC,C$,NC,D$)

      GOTO 130
250   IF C$ <> ")" THEN GOTO 460
      'closing parenthesis
290   IF C$ <> ")" THEN GOTO 300
      NC = NC + 1
      CP$(NC) = ")"
      IC = IC + 1
      C$ = MID$(CH$, IC, 1)
      GOTO 290
300   SU$ = MID$(CH$, IC + 1, 1)
      IF SU$ = "(" OR SU$ = "œ" THEN
        IC = IC + 1
        C$ = SU$
        GOTO 220
      END IF
      IF C$ <> "^" THEN GOTO 370
      'POWER
      NC = NC + 1
      CP$(NC) = "^"
340   IF C$ <> "^" THEN GOTO 350
      NC = NC - 1
      'if CHs[IC+2] in ["0".."9"] then
      IF MID$(CH$, IC + 2, 1) >= "0" AND MID$(CH$, IC + 2, 1) <= "9" THEN
        E1$ = MID$(CH$, IC + 1, 2)            '2 digits exponant
      ELSE
        E1$ = MID$(CH$, IC + 1, 1)            '1 digit exponant
      END IF
      EX = VAL(E1$)
      IC = IC + LEN(E1$)
      C$ = MID$(CH$, IC, 1)
      GOTO 340

350   NC = NC + 1
      CP(NC) = EX
      SU$ = MID$(CH$, IC + 1, 1)
      IF SU$ = "(" OR SU$ = "œ" THEN 'œ for derivative
        IC = IC + 1
        C$ = SU$
        GOTO 220
      END IF

370   IF C$ <> "*" THEN GOTO 130
  'MULT. MONOM
      NC = NC + 1
      CP$(NC) = "*"
      NC = NC + 1
      CP$(NC) = ""
      CP(NC) = 1!
      GOTO 470
  'END of MULT. MONOM
460   NC = NC + 1
      CP(NC) = ISI
      CP$(NC) = ""
   'CONVERT/COMPACT MONOM
470   IF MID$(CH$, IC, 1) < "0" OR MID$(CH$, IC, 1) > "9" OR IC > LEN(CH$) THEN GOTO 510
      NB$ = ""
   'modif. for release 2.0
      IF LEN(E1$) = 2 THEN IC1 = IC - 1 ELSE IC1 = IC
   'read an integer of unknown length
      'While (CHs[IC1] in ["0".."9"]) and (IC1 <= length(CHs)) do
480   IF MID$(CH$, IC1, 1) < "0" OR MID$(CH$, IC1, 1) > "9" OR IC1 > LEN(CH$) THEN GOTO 485
481   NB$ = NB$ + MID$(CH$, IC1, 1)
      IC1 = IC1 + 1
      IF MID$(CH$, IC1, 1) >= "0" AND MID$(CH$, IC1, 1) <= "9" AND IC1 <= LEN(CH$) THEN GOTO 481
485   NB = INT(VAL(NB$))
      IC = IC + LEN(NB$)
      C$ = MID$(CH$, IC, 1)
490 : IF C$ = "^" THEN
        IC = IC + 1
        EN$ = MID$(CH$, IC, 1)
        IEN = INT(VAL(EN$))
        'NB power IEN
        INB = NB
        NB = 1
        FOR I = 1 TO IEN
          NB = NB * INB
        NEXT I
        IC = IC + 1
        C$ = MID$(CH$, IC, 1)
        GOTO 490
      END IF
      CP(NC) = CP(NC) * NB
510   IF C$ < "A" OR C$ > "Z" OR IC > LEN(CH$) THEN GOTO 560
      FOR I = 1 TO 26
        IF ALFA$(I) = C$ THEN NL = I
      NEXT I
      IE(NL) = IE(NL) + 1
      IC = IC + 1
      C$ = MID$(CH$, IC, 1)
      IEX = 1
540   IF C$ = "^" THEN
        IC = IC + 1
        IF MID$(CH$, IC + 1, 1) >= "0" AND MID$(CH$, IC + 1, 1) <= "9" THEN
          EC$ = MID$(CH$, IC, 2)
        ELSE
          EC$ = MID$(CH$, IC, 1)
        END IF
        IVL = INT(VAL(EC$))
        IEX = IEX * IVL
        IC = IC + LEN(EC$)
        C$ = MID$(CH$, IC, 1)
        GOTO 540
      END IF
      IE(NL) = IE(NL) + IEX - 1
560   IF C$ = "*" THEN
        IC = IC + 1
        C$ = MID$(CH$, IC, 1)
        IF C$ = "-" THEN
          CP(NC) = -CP(NC)
          IC = IC + 1
          C$ = MID$(CH$, IC, 1)
        END IF
      END IF
      IF C$ >= "A" AND C$ <= "Z" THEN GOTO 470
      IF C$ >= "0" AND C$ <= "9" THEN GOTO 470
      FOR I = 1 TO 26
        IF IE(I) <> 0 THEN
          CP$(NC) = CP$(NC) + ALFA$(I)
          IF IE(I) > 1 THEN
            IE$ = STR$(IE(I))
            'remove blanks from IE$
            T$ = ""
            FOR II = 1 TO LEN(IE$)
              IF MID$(IE$, II, 1) <> " " THEN T$ = T$ + MID$(IE$, II, 1)
            NEXT II
            CP$(NC) = CP$(NC) + "^" + T$
          END IF
          IE(I) = 0
        END IF
      NEXT I
      'end of closing par.
      GOTO 130
      'end of string analysis main loop

      'simplify monoms if necessary
1000  IDI = NC + 2
      N = IDI: GOSUB 1100
      IF Verif = 0 THEN
        GOSUB 1200
        GOTO 8100
      END IF
      IH = 0
      INO = 0
      LE = IDI / 2
      FOR NC = 1 TO LE
        EC$ = CP$(NC)
        CP$(NC) = CP$(IDI - NC + 1)
        CP$(IDI - NC + 1) = EC$
        EC = CP(NC)
        CP(NC) = CP(IDI - NC + 1)
        CP(IDI - NC + 1) = EC
      NEXT NC
      FOR I = 3 TO IDI
        IF CP$(I) = ")" THEN
          IH = IH + 1
          IPI(IH) = I
          INO = INO + 1
          IPO(INO) = I
        END IF
        IF CP$(I) = "(" THEN
          IHO = IPO(INO)
          CP(IHO) = I
          CP(I) = IHO
          INO = INO - 1
        END IF
      NEXT I
      IF IRE = 1 THEN
        IF IRT = 0 THEN
          PRINT "  SIMPLIFICATION:"
        ELSE
          PRINT #2, "  SIMPLIFICATION:"
        END IF
        GOSUB 10000  'print intermediate result
      END IF

      'operations on monoms
      IHP = IH: IHC = IH: EC = 0!
1465  IF IHP = 0 THEN GOTO 8050
1470  IPF = IPI(IHC)
      JPO = INT(CP(IPF))
      IDM = JPO - 1
      IFM = IPF + 1
      IPP = IPF - 1
      IAP = JPO + 1
      IF CP$(IPP) = "^" AND CP$(IPP - 1) = "(" THEN
        IHC = IHC - 1
        GOTO 1470
      END IF
      IF CP$(IPP) = "^" THEN
        GOSUB 11000     'call PUIS
        IF PUIS <> 0 THEN
          IF IOk = 1 THEN
            GOSUB 1200  'Message (PUIS failed)
            GOTO 8100
          ELSE
            IRE = 0
          END IF
        END IF
      END IF
      IF CP$(IAP) = "^" THEN
        EX = 0!
        FOR i4 = IFM TO IDM
          EX = EX + CP(i4)
        NEXT i4
        IFM = IAP + 2
        IDM = INT(CP(IAP + 1)) - 1
        IO1 = INT(CP(IAP + 1))
        IHP = IHP - 1
        EC = 1!
        GOSUB 11000         'call PUIS
        IF PUIS <> 0! THEN
          IF IOk = 1 THEN
            GOSUB 1200  'Message (PUIS failed)
            GOTO 8100
          ELSE
            IRE = 0
          END IF
        END IF
      END IF
      C$ = LEFT$(CP$(IAP), 1)
      IF C$ = "œ" THEN GOSUB 20000  'call DERI
      M$ = ""
      XM = 1!: IMG = 0: IMD = 0
      IF CP$(IAP) = "*" AND CP$(IAP + 1) <> ")" AND CP$(IAP + 1) <> "$" THEN
        IMG = 1
      END IF
      C$ = LEFT$(CP$(IPP - 1), 1)
      IF CP$(IPP) = "*" AND CP$(IPP - 1) <> "(" AND C$ <> "œ" THEN
        IMD = 1
      END IF
      IF IMG <> 0 OR IMD <> 0 THEN GOTO 8000
1580  IF CP$(IAP) = "*" THEN
        GOSUB 5000     'call PARE
        IF PARE <> 0 THEN
          IF IOk = 1 THEN
            GOSUB 1200 'Message (PARE failed)
            GOTO 8100
          ELSE
            IRE = 0
          END IF
        END IF
        IHP = IHP - 1
      END IF
      IF CP$(IPP) = "*" THEN
        IHC = IHC - 1
        GOTO 1470
      END IF
      IF CP$(IAP) = "-" THEN
        GOSUB 13500 'call SOUS
      ELSE
        GOSUB 13000 'call ADDI
      END IF
      IHP = IHP - 1: IHC = IHC - 1
      GOTO 1465

      'Multiplication of monoms
8000  IF IMG = 1 THEN
        M$ = M$ + CP$(IAP + 1)
        XM = XM * CP(IAP + 1)
        CP$(IAP) = "$"
        CP(IAP) = 0!
        CP$(IAP + 1) = "$"
        CP(IAP + 1) = 0!
        IAP = IAP + 2
      END IF

      IF IMD = 1 THEN
        M$ = M$ + CP$(IPP - 1)
        XM = XM * CP(IPP - 1)
        CP$(IPP) = "$"
        CP(IPP) = 0!
        CP$(IPP - 1) = "$"
        CP(IPP - 1) = 0!
        IPP = IPP - 2
      END IF

      FOR I = IDM TO IFM STEP -1
        IF CP(I) <> 0! THEN
          CP(I) = CP(I) * XM
          T$ = CP$(I) + M$
          GOSUB 1070   'call MONOME(T$)
          CP$(I) = T$
        END IF
      NEXT I
      IF IRE = 1 THEN
        IF IRT = 0 THEN
          PRINT "  MULTIPLICATION OF MONOMS:"
        ELSE
          PRINT #2, "  MULTIPLICATION OF MONOMS:"
        END IF
        GOSUB 10000  'call IMPR
        IF IMPR = 0 THEN GOTO 8100
      END IF
      GOTO 1580

      'final simplifications and  result
8050  IF IRT = 0 THEN
        PRINT
        PRINT "  FINAL SIMPLIFICATION AND RESULT:"
        PRINT
      ELSE
        PRINT #2, ""
        PRINT #2, "  FINAL SIMPLIFICATION AND RESULT:"
        PRINT #2, ""
      END IF
      ISL = IDI - 1
      FOR I = 3 TO ISL
        IF CP(I) <> 0! THEN
          FOR KS = I + 1 TO IDI
            IF CP$(KS) = CP$(I) THEN
              CP(I) = CP(I) + CP(KS)
              CP(KS) = 0!
            END IF
          NEXT KS
        END IF
      NEXT I
      GOSUB 10000  'call IMPR
      IF IRT = 1 THEN CLOSE #2
8100  PRINT
      INPUT "  Evaluate another string (0=NO  1=YES): ", IRF
      IF IRF = 1 THEN GOTO 110

END  'of main program

'   Procedure OPERA(CH$:string,IC:integer,C$:char,NC:integer,D$:String)
'   Look for a derivative operator "£" or an opening "("
'   Labels: 670, 680, 700
600   IF C$ = "£" THEN
670     D$ = ""
680     IF C$ <> "(" THEN
          D$ = D$ + C$
          IC = IC + 1
          C$ = MID$(CH$, IC, 1)
          GOTO 680
        END IF
        NC = NC + 1
        CP$(NC) = D$
      END IF
700   IF C$ = "(" THEN
        NC = NC + 1
        CP$(NC) = "("
        IC = IC + 1
        C$ = MID$(CH$, IC, 1)
        GOTO 700
      END IF
      IF C$ = "£" THEN GOTO 670
      RETURN 'opera

'   Procedure MONOME(T$: String)
'   Simplify monom ex.: BAB ==> AB^2
'   Labels: 1080, 1090
'   II,I2,IVL : integer
'   IE$,SS$ : Strings
'   SC$: char
1070 FOR II = 1 TO 26
      IE(II) = 0
    NEXT II
    I2 = 1
    SC$ = MID$(T$, I2, 1)
1080 IF I2 > LEN(T$) THEN GOTO 1090
    FOR II = 1 TO 26
      IF SC$ = ALFA$(II) THEN NL = II
    NEXT II
    IE(NL) = IE(NL) + 1
    I2 = I2 + 1
    SC$ = MID$(T$, I2, 1)

    IF SC$ = "^" AND I2 <= LEN(T$) THEN
      I2 = I2 + 1
      'modif. for release 2.0
      IF MID$(T$, I2 + 1, 1) >= "0" AND MID$(T$, I2 + 1, 1) <= "9" AND I2 < LEN(T$) THEN
        SS$ = MID$(T$, I2, 2)
      ELSE
        SS$ = MID$(T$, I2, 1)
      END IF
      IVL = INT(VAL(SS$))
      IE(NL) = IE(NL) + IVL - 1
      I2 = I2 + LEN(SS$)
      SC$ = T$(I2)
    END IF
    GOTO 1080

1090 T$ = ""
    FOR I2 = 1 TO 26
      IF IE(I2) <> 0 THEN
        T$ = T$ + ALFA$(I2)
        IF IE(I2) > 1 THEN
          IE$ = STR$(IE(I2))
          'remove blanks from IE$ and put in T1$
          T1$ = ""
          FOR II = 1 TO LEN(IE$)
            IF MID$(IE$, II, 1) <> " " THEN T1$ = T1$ + MID$(IE$, II, 1)
          NEXT II
          T$ = T$ + "^" + T1$
        END IF
        IE(I2) = 0
      END IF
    NEXT I2
    RETURN 'MONOME


'   Function Verif(N:integer): integer
'   return 1 if index N > MaxSize else return 0
1100 IF N > MaxSize THEN
        Verif = 0
      ELSE
        Verif = 1
     END IF
     RETURN

'    Subroutine Message
'    Message given if a table index > MaxSize
'    To be used after a call to Verif.       }
1200 IF IRT = 0 THEN
       PRINT "  Too many terms!"
     ELSE
       PRINT #2, "  Too many terms!"
       CLOSE #2
     END IF
     RETURN

'   Function SIMPLI(IS1:integer): integer
'   simplify polynomial
'   Var  IS2,NB : integer
1300 SIMPLI = 0!
     N = IS1: GOSUB 1100
     IF Verif = 0 THEN
       SIMPLI = IS1
       RETURN
     END IF
     IF IS1 = 1 THEN
       NS = 1
       RETURN
     END IF
     IS2 = IS1 - 1
     FOR NB = 1 TO IS2
       IF SI(NB) <> 0! THEN
         FOR KS = NB + 1 TO IS1
           IF SI$(KS) = SI$(NB) THEN
             SI(NB) = SI(NB) + SI(KS)
             SI(KS) = 0!
           END IF
         NEXT KS
       END IF
     NEXT NB

     NS = 0
     FOR I = 1 TO IS1
       IF SI(I) <> 0! THEN
         NS = NS + 1
         N = NS: GOSUB 1100
         IF Verif = 0 THEN
           SIMPLI = NS
           RETURN
         END IF
         SI$(NS) = SI$(I)
         SI(NS) = SI(I)
       END IF
     NEXT I

     IF NS = 0 THEN
       NS = 1
       SI$(1) = ""
     END IF
     RETURN

'   Function PARE: integer
'   MULTIPLY PARENTHESES
'   Labels: 5010, 5054, 5075
'   ID1,ID2,IF1,IF2,IO2,IS1,IUM,L1,L2,N1,N2: integers
'   I,J,MA,MB,NM: integers
5000  PARE = 0: IOk = 1
      FOR I = 1 TO MaxSize
        SI$(I) = ""
      NEXT I
      IO2 = JPO
      IF2 = IPF
      IF1 = IAP + 1

5010  IF CP$(IF1) = "$" AND IF1 < IDI THEN
        IF1 = IF1 + 1
        GOTO 5010
      END IF
      IO1 = INT(CP(IF1))
      ID1 = IO1 - 1
      L1 = IF1 + 1
      ID2 = IO2 - 1
      L2 = IF2 + 1
      IF ID1 = L1 THEN
        N1 = 1
        GOTO 5054
      END IF
      IUM = 0

      FOR I = ID1 TO L1 STEP -1
        IUM = IUM + 1
        N = IUM: GOSUB 1100  'call Verif
        IF Verif = 0 THEN
          PARE = IUM
          RETURN
        END IF
        SI$(IUM) = CP$(I)
        SI(IUM) = CP(I)
      NEXT I

      IS1 = IUM
      GOSUB 1300          'call SIMPLI
      IF SIMPLI > 0 THEN  'something wrong
        PARE = SIMPLI
        RETURN
      END IF
      N1 = NS
      IUM = L1 - 1
      FOR I = N1 TO 1 STEP -1
        IUM = IUM + 1
        N = IUM: GOSUB 1100  'call Verif
        IF Verif = 0 THEN
          PARE = IUM         'something wrong
          RETURN
        END IF
        CP$(IUM) = SI$(I)
        CP(IUM) = SI(I)
      NEXT I

5054  IF ID2 = L2 THEN
        N2 = 1
        GOTO 5075
      END IF
      IUM = 0
      FOR I = ID2 TO L2 STEP -1
        IUM = IUM + 1
        N = IUM: GOSUB 1100     'call Verif
        IF Verif = 0 THEN
          PARE = IUM
          RETURN
        END IF
        SI$(IUM) = CP$(I)
        SI(IUM) = CP(I)
      NEXT I

      IS1 = IUM
      GOSUB 1300         'call SIMPLI
      IF SIMPLI > 0 THEN 'something wrong
        PARE = SIMPLI
        RETURN
      END IF
      N2 = NS
      IUM = L2 - 1
      FOR I = N2 TO 1 STEP -1
        IUM = IUM + 1
        N = IUM: GOSUB 1100     'call Verif
        IF Verif = 0 THEN
          PARE = IUM
          RETURN
        END IF
        CP$(IUM) = SI$(I)
        CP(IUM) = SI(I)
      NEXT I

5075  MA = N1 + L1 - 1
      MB = N2 + L2 - 1
      NM = 0
      FOR I = MA TO L1 STEP -1
        FOR J = MB TO L2 STEP -1
          T$ = CP$(I) + CP$(J)
          GOSUB 1070    'call MONOME(T$)
          NM = NM + 1
          N = NM: GOSUB 1100     'call verif
          IF Verif = 0 THEN
            PARE = NM
            RETURN
          END IF
          SI$(NM) = T$
          SI(NM) = CP(I) * CP(J)
        NEXT J
      NEXT I

      IS1 = NM
      GOSUB 1300      'call SIMPLI
      IF SIMPLI > 0 THEN
        PARE = SIMPLI
        RETURN
      END IF
      IR = IF2
      IDC = NS - IO1 + L2

      GOSUB 9000  'call COPIE
      IF COPIE > 0 THEN
        PARE = COPIE
        RETURN
      END IF
      IF IRE = 1 THEN
        IF IRT = 0 THEN
          PRINT "  PARENTHESES MULTIPLICATION:"
        ELSE
          PRINT #2, "  PARENTHESES MULTIPLICATION:"
        END IF
        GOSUB 10000  'call IMPR
        IF IMPR = 0 THEN
          IOk = 0
          PARE = -1
        END IF
      END IF
    RETURN 'PARE

'   Function COPIE: integer
'   Label 9620, 9840
'   Var  I,IHR,IZZ : integer
'   CO : real
9000  COPIE = 0!
      IF IDC <= 0 THEN
        FOR I = NS TO 1 STEP -1
          IR = IR + 1
          CP$(IR) = SI$(I)
          CP(IR) = SI(I)
        NEXT I
        JPO = IR + 1
        CP$(JPO) = "("
        CP(JPO) = IPF
        CP(IPF) = JPO
        IDM = JPO - 1
        IAP = IO1 + 1
9620    IF CP$(IAP) = "$" THEN
          IAP = IAP + 1
          GOTO 9620
        END IF
        IF IO1 = IDI THEN IDI = IDI + IDC
        IF IDC = 0 THEN RETURN
        FOR I = JPO + 1 TO IO1
          CP$(I) = "$"
          CP(I) = 0!
        NEXT I
        RETURN
      END IF

      IF IO1 <> IDI THEN
        IZZ = IO1 + 1
        IHR = IHC - 1
        FOR I = 1 TO IHR
          CO = CP(IPI(I))
          IF CO > JPO THEN CP(IPI(I)) = CO + IDC
        NEXT I
        I = IDI + IDC
        N = I: GOSUB 1100  'call Verif
        IF Verif = 0 THEN
          COPIE = I
          RETURN
        END IF
        FOR I = IDI TO IZZ STEP -1
          CP$(I + IDC) = CP$(I)
          IF CP$(I) = ")" THEN
            CP(I + IDC) = CP(I) + IDC
            GOTO 9840
          END IF
          IF CP$(I) = "(" AND CP(I) > IPF THEN
            CP(I + IDC) = CP(I) + IDC
            GOTO 9840
          END IF
          CP(I + IDC) = CP(I)
9840    NEXT I
      END IF

      IDI = IDI + IDC
      N = NS: GOSUB 1100  'call Verif
      IF Verif = 0 THEN
        COPIE = NS
        RETURN
      END IF
      FOR I = NS TO 1 STEP -1
        IR = IR + 1
        CP$(IR) = SI$(I)
        CP(IR) = SI(I)
      NEXT I

      JPO = IR + 1
      CP$(JPO) = "("
      CP(JPO) = IPF
      CP(IPF) = JPO
      IDM = JPO - 1
      IAP = JPO + 1
      IF CP$(IAP) <> "$" THEN RETURN
9850  IAP = IAP + 1
      IF CP$(IAP) = "$" THEN GOTO 9850
    RETURN  'COPIE

'   FUNCTION IMPR : boolean
'   print intermediate or final results
'   Label 500
'   Var  I,IMO,INO,ISP,LR,LR1,LR2 : integer
'        Zs  : array[0..10] of char
'        Zcp : array[0..40] of char
10000 IMPR = 1
      ISP = 0
      'Empty string RR$
      RR$ = ""

'     for debugging only
'     FOR I = IDI TO 3 STEP -1
'       PRINT #2, " i="; I; " CP$="; CP$(I); " CP=", CP(I)
'     NEXT I
'     INPUT "", rep$

      FOR I = IDI TO 3 STEP -1
        IF CP$(I) = "$" THEN GOTO 10500
        IMO = 0: INO = 0
        IF CP$(I) >= "A" AND CP$(I) <= "Z" THEN IMO = 1
        IF CP$(I) = "" THEN INO = 1
        IF ISP = 1 THEN
          IF (IMO = 1 OR INO = 1) AND CP(I) > 0! AND LEN(RR$) > 0 THEN
            RR$ = RR$ + "+"
          END IF
          IF CP$(I) = "(" THEN RR$ = RR$ + "+"
        END IF

        IF (IMO = 1 OR INO = 1) AND INT(ABS(CP(I))) <> 1 AND CP(I) <> 0! THEN
          Z$ = STR$(INT(CP(I)))
          'remove  blanks of Z$ if necessary and put in T$
          T$ = ""
          FOR II = 1 TO LEN(Z$)
            IF MID$(Z$, II, 1) <> " " THEN T$ = T$ + MID$(Z$, II, 1)
          NEXT II
          RR$ = RR$ + T$
        END IF

        IF INT(CP(I)) = -1 AND CP$(I) = "" THEN RR$ = RR$ + "-1"

        IF INT(CP(I)) = -1 AND CP$(I) <> "" THEN RR$ = RR$ + "-"

        IF INT(CP(I)) = 1 AND CP$(I) = "" THEN RR$ = RR$ + "1"

        IF CP(I) <> 0! THEN RR$ = RR$ + CP$(I)

        'only for intermediate results
        C$ = LEFT$(CP$(I), 1)
        IF CP(I) = 0 AND (C$ = "*" OR C$ = "+" OR C$ = "-") THEN
          RR$ = RR$ + CP$(I)
        END IF
        ISP = 0
        IF IMO = 1 OR INO = 1 OR CP$(I) = ")" THEN ISP = 1
10500 NEXT I
     
      LR = LEN(RR$)
      IF IRT = 0 THEN   'case print to screen
      IF LR = 0 THEN
        PRINT "  0"
      ELSE
        PRINT "  "; LEFT$(RR$, 70)
      END IF
      IF LR > 70 THEN
        PRINT "  "; MID$(RR$, 71, 70)
      END IF
      IF LR > 140 THEN
        PRINT "  "; MID$(RR$, 141, 70)
      END IF
      IF LR > 210 THEN
        PRINT "  "; MID$(RR$, 211, 70)
      END IF
      IF LR > 280 THEN
        PRINT "  "; MID$(RR$, 281, 70)
      END IF
      IF LR > 350 THEN
        PRINT "  "; MID$(RR$, 351, 70)
      END IF
      IF LR > 420 THEN
        PRINT "  "; MID$(RR$, 421, 70)
      END IF
      IF LR > 490 THEN
        PRINT "  "; MID$(RR$, 491, 70)
      END IF
      IF LR > 560 THEN
        PRINT "  "; MID$(RR$, 561, 70)
      END IF
      IF LR > 630 THEN
        PRINT "  "; MID$(RR$, 631, 70)
      END IF
      IF LR > 700 THEN
        PRINT "  "; MID$(RR$, 701, 70)
      END IF
      IF LR > 770 THEN
        PRINT "  RESULT STRING TOO BIG (>"; LR; ") !"
        IMPR = 0
      END IF
      ELSE   'case print to output file ALGEBRA.LST
             'lines are terminated with blanks
      IF LR < 70 THEN
        LR2 = 69 - LR
        FOR I = LR TO LR + LR2
          RR$ = RR$ + " "
        NEXT I
      ELSEIF LR < 770 THEN
        LR1 = LR / 70
        LR2 = LR - LR1 * 70
        FOR I = LR TO LR + 69 - LR2
          RR$ = RR$ + " "
        NEXT I
      END IF
      IF LR = 0 THEN
        PRINT #2, "  0"
      ELSE
        PRINT #2, "  "; LEFT$(RR$, 70)
      END IF
      IF LR > 70 THEN
        PRINT #2, "  "; MID$(RR$, 71, 70)
      END IF
      IF LR > 140 THEN
        PRINT #2, "  "; MID$(RR$, 141, 70)
      END IF
      IF LR > 210 THEN
        PRINT #2, "  "; MID$(RR$, 211, 70)
      END IF
      IF LR > 280 THEN
        PRINT #2, "  "; MID$(RR$, 281, 70)
      END IF
      IF LR > 350 THEN
        PRINT #2, "  "; MID$(RR$, 351, 70)
      END IF
      IF LR > 420 THEN
        PRINT #2, "  "; MID$(RR$, 421, 70)
      END IF
      IF LR > 490 THEN
        PRINT #2, "  "; MID$(RR$, 491, 70)
      END IF
      IF LR > 560 THEN
        PRINT #2, "  "; MID$(RR$, 561, 70)
      END IF
      IF LR > 630 THEN
        PRINT #2, "  "; MID$(RR$, 631, 70)
      END IF
      IF LR > 700 THEN
        PRINT #2, "  "; MID$(RR$, 701, 70)
      END IF
      IF LR > 770 THEN
        PRINT #2, "  RESULT STRING TOO BIG (>"; LR; ") !"
        IMPR = 0
      END IF
      END IF
    RETURN

'   Function PUIS: integer
'   Integer power of a polynomial
'   Labels: 11080, 11480, 11485
'   I,IS1,ITP,IU,IUP,IX1,IZP,JP,KP: integers
11000 PUIS = 0!: IOk = 1
'     current exponant is put in EX
      IF EC = 0! THEN
        EX = CP(IPP - 1)
        IO1 = JPO
      END IF
      IF EX = 0! THEN
        SI$(1) = ""
        SI(1) = 1!
        NS = 1
        GOTO 11480
      END IF
      IF EX = 1! THEN
        IF EC = 0! THEN GOTO 11485
        IUP = 0
        FOR I = IDM TO IFM STEP -1
          IUP = IUP + 1
          N = IUP: GOSUB 1100    'call Verif
          IF Verif = 0 THEN
            PUIS = IUP           'something wrong
            RETURN
          END IF
          SI$(IUP) = CP$(I)
          SI(IUP) = CP(I)
        NEXT I
        NS = IDM - IFM + 1
        GOTO 11480
      END IF

      ITP = IDM - IFM + 1
      IF ITP = 1 THEN
        NS = 1
        P$(1) = CP$(IFM)
        P(1) = CP(IFM)
        GOTO 11080
      END IF
      I = 0
      FOR JP = IDM TO IFM STEP -1
        I = I + 1
        N = I: GOSUB 1100
        IF Verif = 0 THEN
          PUIS = I
          RETURN
        END IF
        SI$(I) = CP$(JP)
        SI(I) = CP(JP)
      NEXT JP

      IS1 = ITP
     
      GOSUB 1300  'call SIMPLI

      IF SIMPLI > 0! THEN
        PUIS = SIMPLI
        RETURN
      END IF

      IX1 = IFM + NS - 1
      IUP = IX1 + 1
      N = IUP: GOSUB 1100
      IF Verif = 0 THEN
        PUIS = IUP
        RETURN
      END IF
      FOR I = 1 TO NS
        IUP = IUP - 1
        CP$(IUP) = SI$(I)
        CP(IUP) = SI(I)
        P$(I) = SI$(I)
        P(I) = SI(I)
      NEXT I

11080 IEX = INT(EX) - 1
      FOR KP = 1 TO IEX
        IZP = 0
        FOR I = IX1 TO IFM STEP -1
          FOR IU = 1 TO NS
            IZP = IZP + 1
            N = IZP: GOSUB 1100
            IF Verif = 0 THEN
              PUIS = IZP
              RETURN
            END IF
            T$ = CP$(I) + P$(IU)
            GOSUB 1070  'call MONOME(T$)
            SI$(IZP) = T$
            SI(IZP) = CP(I) * P(IU)
          NEXT IU
        NEXT I

        IS1 = IZP
        GOSUB 1300  'call SIMPLI
        IF SIMPLI > 0! THEN
          PUIS = SIMPLI
          RETURN
        END IF

        N = NS: GOSUB 1100
        IF Verif = 0 THEN
          PUIS = NS
          RETURN
        END IF
        FOR I = 1 TO NS
          P$(I) = SI$(I)
          P(I) = SI(I)
        NEXT I
      NEXT KP

11480 IDC = NS - IO1 + IPF + 1

      IR = IPF
      GOSUB 9000  'call COPIE

      IF EC = 1! THEN IFM = IPF + 1
11485 IF EC = 0! THEN
        CP$(IPP) = "$"
        CP(IPP) = 0!
        CP$(IPP - 1) = "$"
        CP(IPP - 1) = 0!
        IPP = IPP - 2
      END IF

      IF IRE = 1 THEN
        IF IRT = 0 THEN
          PRINT "  POWER:"
        ELSE
          PRINT #2, "  POWER:"
        END IF
        GOSUB 10000  'call IMPR
        IF IMPR = 0 THEN
          IOk = 0
          PUIS = -1!
        END IF
      END IF
      EC = 0!
    RETURN 'PUIS

'   Procedure ADDI
'   suppress parentheses with a preceding + sign or no sign
13000 CP(JPO) = 0!
      CP(IPF) = 0!
      CP$(JPO) = "$"
      CP$(IPF) = "$"
      IF CP$(IAP) = "+" THEN
        CP$(IAP) = "$"
        CP(IAP) = 0!
      END IF
      IF IRE = 1 THEN
        IF IRT = 0 THEN
          PRINT "  ADDITION:"
        ELSE
          PRINT #2, "  ADDITION:"
        END IF
        GOSUB 10000  'call IMPR
      END IF
    RETURN

'   Procedure SOUS
'   suppress parentheses with a preceding - sign
13500 FOR I = IDM TO IFM STEP -1
        CP(I) = -CP(I)
      NEXT I
      CP(JPO) = 0!
      CP(IPF) = 0!
      CP$(JPO) = "$"
      CP$(IPF) = "$"
      CP$(IAP) = "$"
      CP(IAP) = 0!
      IF IRE = 1 THEN
        IF IRT = 0 THEN
          PRINT "  SUBSTRACTION:"
        ELSE
          PRINT #2, "  SUBSTRACTION:"
        END IF
        GOSUB 10000  'call IMPR
      END IF
    RETURN

20000 'Procedure DERI
      'derivation not implemented
      RETURN

'      Last update 01/22/2003 (11/07/1994 for french edition)
'      J-P MOREAU, PARIS  (available Fortran 77 release)

' End of file algebra.bas
'