DEFINT A-Z
DECLARE FUNCTION INCALCUL$ ()
DECLARE FUNCTION RESULTAT$ (a$)
DECLARE FUNCTION Test (a$, er)

SCREEN 0, 0, 0, 0
ON ERROR GOTO ERREUR
DO
  'cr‚ation d'une chaine valide … ‚valuer
  CLS : k$ = INCALCUL$: IF k$ = CHR$(27) THEN EXIT DO
  '‚valuation
  G$ = RESULTAT$(k$): LOCATE , , 0
  'affichage du r‚sultat ou d'une erreur
  IF errcal$ = "" THEN
     PRINT : PRINT G$;
  ELSE
     LOCATE 23, 1: PRINT errcal$; TAB(80); " "; : errcal$ = ""
  END IF
  k$ = INPUT$(1): LOCATE 23, 1: PRINT TAB(80); " ";
LOOP UNTIL k$ = CHR$(27)
CLS
END

ERREUR:
SOUND 4000, 3
SELECT CASE ERR
CASE 11
     errcal$ = " PAS DE DIVISION PAR ZERO !"
CASE 6
     errcal$ = " DEPASSEMENT DE CAPACITE DE CALCUL !"
CASE ELSE
     errcal$ = "Erreur impr‚vue Nø" + STR$(ERR)
END SELECT
RESUME NEXT

DOC:
DATA "   MODE D'EMPLOI"
DATA
DATA "   [+] Addition,   [-] Soustraction,   [*] Multiplication,   [/] Division"
DATA "   [^] Puissance,  [.] est la virgule d‚cimale               [F1] Mode d'emploi"
DATA "   [ESC]  Quitter le programme         [ENTER]  Evalue l'expression en cours."
DATA "   ÄÄ Le programme respecte la syntaxe alg‚brique classique, un texte d'aide"
DATA "      (et/ou) un beep indique toutes erreurs de syntaxe."
DATA "   ÄÄ Deux op‚rateurs cons‚cutifs sont refus‚s sauf *- , /- ou ^- compris"
DATA "      comme la multiplication, la division ou la puissance n‚gative."
DATA "   ÄÄ Chaque terme num‚rique doit ˆtre ‚crit sous forme d‚cimale de"
DATA "      16 caractŠres maximum, pas de forme exponentielle telle '1,3D+4',"
DATA "      On peut toutefois ‚crire 10^6 , 10^-3 ou 1.475*5.1^-6.23"
DATA "   ÄÄ La pr‚cision du r‚sultat est de 16 chiffres significatifs."
DATA "      Ce r‚sultat est affich‚  avec sa pr‚cision maximum ."
DATA "   ÄÄ Les r‚sultats sont arrondis (et/ou) ‚crits sous forme exponentielle"
DATA "      si leurs repr‚sentations d‚passent la pr‚cision maximum."
DATA "   ÄÄ Les flŠches [Gauche] et [Droite] d‚placent le curseur en vue de corriger."
DATA "   ÄÄ L'appui sur les touches [backspace] ou [delete] permettent de corriger."
DATA
DATA "   Observons quelques exemples de calculs r‚alis‚s:"
DATA "   10+4*2+1= 19  ;10-4*-2+1= 19  ;10.3-4/2-1= 7.3  ;-5+2.1*3/7*5-1.1= -1.6"
DATA "      ÀÂÙ            ÀÂÄÙ              ÀÂÙ              ÀÄÄÁÂÁÄÙ"
DATA "   10 +8 +1= 19  ;10 +8  +1= 19  ;10.3 -2 -1= 7.3  ;-5    +4.5  -1.1= -1.6"
DATA "   2^5*2^3/256=1 ;         2^.5 = 1.414213562373095        (La racine de 2)"
DATA "   1+10^-3^4 = 1+10 puissance(-3*4) =  1+10^-12 =  1.000000000001"

FUNCTION INCALCUL$
DIM e$(6)
e$(0) = " Seul un chiffre peut ˆtre derriŠre un point d‚cimal"
e$(1) = " Valeur num‚rique de plus de 16 chiffres significatifs"
e$(2) = " Valeur num‚rique contenant plusieurs points d‚cimaux"
e$(3) = " Le caractŠre pr‚c‚dent est d‚j… un op‚rateur"
e$(4) = " Pas d'expression … ‚valuer !"
e$(5) = " Le dernier caractŠre de la ligne ne peut ˆtre un op‚rateur"
e$(6) = " Les op‚rateurs *,/,^,! sont interdits en d‚but de ligne"
c1$ = ":=;,&‚" + CHR$(34) + "'(Š_‡…": c2$ = "/+..123457890"

dc = POS(0): dl = CSRLIN: LOCATE , , 1, 5, 7
DO
  DO
    k$ = INKEY$: WHILE k$ = "": k$ = INKEY$: WEND
    IF sit > 0 THEN dcar$ = MID$(a$, sit, 1) ELSE dcar$ = ""
    i = INSTR(c1$, k$): IF i THEN k$ = MID$(c2$, i, 1)
    IF INSTR("0123456789", k$) <> 0 THEN
       IF nch < 16 THEN
           nch = nch + 1: EXIT DO
       ELSE
           IF ins = 1 THEN EXIT DO
           er = 1: GOSUB AffEr
       END IF
    ELSEIF k$ = "." THEN
       IF dec = 0 AND nch < 16 THEN
          dec = 1: EXIT DO
       ELSE
          IF ins = 1 THEN EXIT DO
          IF dec = 1 THEN er = 2 ELSE er = 1
          GOSUB AffEr
       END IF
    ELSEIF k$ = "-" THEN
       IF dcar$ = "." THEN
           er = 0: GOSUB AffEr
       ELSEIF dcar$ = "" THEN
           dec = 0: nch = 0: EXIT DO
       ELSEIF INSTR("+-", dcar$) = 0 OR dcar$ = "" THEN
           dec = 0: nch = 0: EXIT DO
       ELSE
           er = 3: GOSUB AffEr
       END IF
    ELSEIF k$ = "+" THEN
       IF dcar$ = "." THEN
           er = 0: GOSUB AffEr
       ELSEIF INSTR("*+-/", dcar$) = 0 OR dcar$ = "" THEN
           dec = 0: nch = 0: EXIT DO
       ELSE
           er = 3: GOSUB AffEr
       END IF
    ELSEIF k$ = "*" OR k$ = "/" OR k$ = "^" THEN
       IF dcar$ = "." THEN
           er = 0: GOSUB AffEr
       ELSEIF INSTR("*+-^/", dcar$) = 0 THEN
          dec = 0: nch = 0: EXIT DO
       ELSE
          IF dcar$ = "" THEN er = 6 ELSE er = 3
          GOSUB AffEr
       END IF
    ELSEIF k$ = CHR$(8) AND sit > 0 THEN
       GOSUB EFCAR
    ELSEIF k$ = CHR$(13) THEN
       IF a$ = "" THEN
          er = 4: GOSUB AffEr
       ELSE
          GOSUB teste
          IF x = 0 THEN
             LOCATE lin, col: INCALCUL$ = a$
             EXIT FUNCTION
          ELSE
             sit = x - 1: icol = x MOD 80: ilin = dl + x \\ 80
             IF icol = 0 THEN icol = 80: ilin = ilin - 1
             ins = 1: LOCATE 23, 1: SOUND 99, 1
             PRINT e$(er); "  Corriger..."; TAB(80); " ";
             LOCATE ilin, icol
             k$ = INKEY$: WHILE k$ = "": k$ = INKEY$: WEND
             x = 0: LOCATE 23, 1: PRINT TAB(80); " "; : LOCATE ilin, icol
          END IF
       END IF
    ELSEIF k$ = CHR$(27) THEN
       INCALCUL$ = k$: EXIT FUNCTION
    ELSEIF k$ = CHR$(0) + CHR$(59) THEN
       RESTORE DOC
       FOR i = 1 TO 25: LOCATE i, 1: READ F$: PRINT F$; TAB(80); " "; : NEXT
       SLEEP: CLS
    ELSEIF k$ = CHR$(0) + CHR$(75) THEN     'gauche
       IF sit = 0 THEN
          SOUND 99, 1
       ELSE
          IF icol = 1 THEN icol = 80: ilin = ilin - 1 ELSE icol = icol - 1
          ins = 1: sit = sit - 1: LOCATE ilin, icol: nch = 0: dec = 0
       END IF
    ELSEIF k$ = CHR$(0) + CHR$(77) THEN     'droite
       IF sit = lon THEN
          SOUND 99, 1
       ELSE
          IF icol = 80 THEN icol = 1: ilin = ilin + 1 ELSE icol = icol + 1
          LOCATE ilin, icol: sit = sit + 1: nch = 0: dec = 0
          IF sit = lon THEN ins = 0
       END IF
    ELSEIF k$ = CHR$(0) + CHR$(83) THEN     'supp
          IF ins = 1 AND lon > sit THEN
             a$ = LEFT$(a$, sit) + RIGHT$(a$, lon - sit - 1): LOCATE dl, dc
             PRINT a$ + " "; : LOCATE dl, dc: PRINT a$;
             col = POS(0): lin = CSRLIN: lon = lon - 1: LOCATE ilin, icol
             IF lon = sit THEN ins = 0
          ELSE
             SOUND 99, 1
          END IF
    ELSEIF k$ = CHR$(0) + CHR$(79) THEN     'fin
       ins = 0: LOCATE lin, col: icol = col: ilin = lin: sit = lon
    ELSEIF k$ = CHR$(0) + CHR$(71) THEN     'debut
       ins = 1: LOCATE dl, dc: icol = dc: ilin = dl: sit = 0
    ELSE
       SOUND 98, .5
    END IF
  LOOP
  IF ins = 0 THEN
     a$ = a$ + k$: FOR i = 1 TO LEN(k$): PRINT MID$(k$, i, 1); : NEXT
     lon = lon + LEN(k$): sit = lon: col = POS(0): lin = CSRLIN: ilin = lin: icol = col
  ELSE
     a$ = LEFT$(a$, sit) + k$ + RIGHT$(a$, lon - sit): LOCATE dl, dc: PRINT a$;
     lon = lon + LEN(k$): sit = sit + LEN(k$): col = POS(0): lin = CSRLIN
     icol = icol + LEN(k$): IF icol > 80 THEN icol = icol MOD 80: ilin = ilin + 1
     LOCATE ilin, icol
  END IF
LOOP

AffEr:
pl = CSRLIN: pc = POS(0): LOCATE 23, 1:  SOUND 99, 1
PRINT e$(er); TAB(80); " "; : LOCATE pl, pc
k$ = INKEY$: WHILE k$ = "": k$ = INKEY$: WEND
LOCATE 23, 1: PRINT TAB(80); " "; : LOCATE pl, pc: k$ = ""
RETURN

EFCAR:
a$ = LEFT$(a$, sit - 1) + RIGHT$(a$, lon - sit): LOCATE dl, dc
PRINT a$ + " "; : LOCATE dl, dc: PRINT a$;
col = POS(0): lin = CSRLIN: lon = lon - 1: sit = sit - 1
IF icol = 1 THEN icol = 80: ilin = ilin - 1 ELSE icol = icol - 1
LOCATE ilin, icol
IF ins = 0 THEN
   IF nch OR dec THEN
      IF dcar$ = "." THEN dec = 0 ELSE nch = nch - 1
   ELSE
      FOR F = LEN(a$) TO 1 STEP -1
          IF INSTR("0123456789", MID$(a$, F, 1)) = 0 THEN EXIT FOR
          nch = nch + 1
      NEXT
   END IF
END IF
RETURN

teste:
IF INSTR("*+/-^.", RIGHT$(a$, 1)) > 0 THEN x = LEN(a$): er = 5: RETURN
car$ = "": dec = 0: nch = 0
FOR II = 1 TO LEN(a$)
    dcar$ = car$: car$ = MID$(a$, II, 1)
    IF INSTR("0123456789", car$) THEN
       nch = nch + 1: IF nch > 16 THEN er = 1: x = II: RETURN
    ELSEIF car$ = "." THEN
       dec = dec + 1: IF dec > 1 THEN er = 2: x = II: RETURN
    ELSE
       dec = 0: nch = 0
       IF car$ = "+" THEN
          IF dcar$ = "." THEN er = 0: x = II: RETURN
          IF dcar$ <> "" THEN IF INSTR("*+-/", dcar$) > 0 THEN er = 3: x = II: RETURN
       ELSEIF car$ = "-" THEN
          IF dcar$ = "." THEN er = 0: x = II: RETURN
          IF dcar$ <> "" THEN IF INSTR("+-", dcar$) > 0 THEN er = 3: x = II: RETURN
       ELSEIF car$ = "*" OR car$ = "/" OR car$ = "^" THEN
          IF dcar$ = "." THEN er = 0: x = II: RETURN
          IF dcar$ = "" THEN er = 6: x = II: RETURN
          IF INSTR("*+-^/", dcar$) > 0 THEN er = 3: x = II: RETURN
       END IF
    END IF
NEXT
RETURN
END FUNCTION

DEFDBL T
FUNCTION RESULTAT$ (ax$)
SHARED errcal$
FOR i = 1 TO LEN(ax$)
    dcar$ = car$: car$ = MID$(ax$, i, 1)
    IF INSTR("0123456789.", car$) > 0 THEN
       a$ = a$ + car$
    ELSEIF car$ = "+" THEN
       IF dcar$ = "" OR INSTR("^", dcar$) > 0 THEN
          'rien faire
       ELSE
          a$ = a$ + car$
       END IF
    ELSE
       a$ = a$ + car$
    END IF
NEXT
x = 1: CH$ = "": Px = 1: dcar$ = "": car$ = ""
FOR i = 1 TO LEN(a$)
    IF errcal$ <> "" THEN EXIT FUNCTION
    dcar$ = car$: car$ = MID$(a$, i, 1)
    IF INSTR("0123456789.", car$) THEN
        CH$ = CH$ + car$
    ELSE
        IF car$ = "^" THEN
           IF P THEN Px = Px * VAL(CH$) ELSE TP = VAL(CH$)
           P = P + 1: CH$ = ""
        ELSEIF car$ = "+" THEN
           IF INSTR("^+-*/", dcar$) = 0 THEN GOSUB ADDSOUS: x = 1
        ELSEIF car$ = "-" THEN
           IF i > 1 AND (k OR P) THEN
              IF INSTR("*/^", MID$(a$, i - 1, 1)) THEN
                 CH$ = CH$ + car$
              ELSE
                 GOSUB ADDSOUS: x = -1
              END IF
           ELSE
              GOSUB ADDSOUS: x = -1
           END IF
        ELSEIF car$ = "*" OR car$ = "/" THEN
           GOSUB MULTDIVPUIS: IF car$ = "*" THEN k = 1 ELSE k = 2
        END IF
    END IF
NEXT
GOSUB ADDSOUS
w$ = LTRIM$(STR$(T)): xxx = INSTR(w$, "D")
IF xxx THEN
   xx$ = RIGHT$(w$, LEN(w$) - xxx)
   IF ASC(xx$) = 43 THEN xx$ = RIGHT$(xx$, LEN(xx$) - 1)
   w$ = LEFT$(w$, xxx - 1) + "*10^" + xx$
END IF
RESULTAT$ = w$
EXIT FUNCTION

ADDSOUS:
GOSUB MULTDIVPUIS
T = T + T2 * x: k = 0
RETURN

MULTDIVPUIS:
T1 = VAL(CH$): CH$ = ""
IF P THEN T1 = TP ^ (Px * T1): Px = 1: P = 0
IF k = 1 THEN
   T2 = T2 * T1
ELSEIF k = 2 THEN
   T2 = T2 / T1
ELSE
   T2 = T1
END IF
RETURN

END FUNCTION