(**********************************************************************)
(* *)
(* TeCal - Text Calculator *)
(* *)
(* Autor : Andreas Schmeink 06.09.1984 *)
(* Korrektur: Hilmar v.d. Bussche 17.09.1984 *)
(* 20.09.1984 *)
(* Adaption : Uwe Behrend, Andreas Schmeink 03.08.1987 *)
(**********************************************************************)
PACKET pick DEFINES pick up number, left range, right range,
replace number, last pick up ok :
(********************************************************************)
(* *)
(* Zahlen erkennen und schreiben für TeCal 12.09.84 *)
(* *)
(********************************************************************)
LET ziffern = "0123456789", pseudoblankcode = 223;
ROW 10 REAL VAR ziffer plus eins
:= ROW 10 REAL : (0.0,1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0);
REAL VAR number;
BOOL VAR ziffer gefunden;
INT VAR anfang, ende, zeichencode, vorkommastellen, p, dezimalzeichen;
TEXT VAR worktext;
BOOL PROC last pick up ok:
ziffer gefunden
END PROC last pick up ok;
REAL PROC code to digit (INT CONST code) :
ziffer plus eins (code-47)
END PROC code to digit;
INT PROC left range :
anfang
END PROC left range;
INT PROC right range :
ende
END PROC right range;
REAL PROC pick up number (TEXT CONST source, INT CONST where) :
suche ende der zahl;
lies zahl ein;
number.
suche ende der zahl :
fange bei gegebener position an;
IF vorzeichen THEN
nach rechts ruecken
FI;
WHILE erlaubtes zeichen REP
nach rechts ruecken
PER;
ende merken.
fange bei gegebener position an:
ziffer gefunden := FALSE;
p := where;
betrachte aktuelles zeichen.
nach rechts ruecken:
p INCR 1;
betrachte aktuelles zeichen.
nach links ruecken:
p DECR 1;
betrachte aktuelles zeichen.
ende merken :
ende := p - 1.
lies zahl ein :
fange hinter der zahl an;
sammle ziffern auf;
pruefe vorzeichen;
werte exponent aus.
sammle ziffern auf :
REP
nach links ruecken;
IF ziffer THEN
ziffer behandeln
ELIF punkt OR komma THEN
IF wirkt als dezimalzeichen THEN
dezimalzeichen behandeln
ELSE ignorieren
FI
ELIF pseudoblank vor ziffer THEN
ignorieren
ELSE
LEAVE sammle ziffern auf
FI;
PER.
pruefe vorzeichen :
IF minus THEN
anfang := p;
number := number * -1.0
ELIF plus THEN
anfang := p
ELSE
anfang := p+1
FI.
werte exponent aus :
set exp (vorkommastellen+decimal exponent(number), number).
fange hinter der zahl an :
vorkommastellen := 0;
dezimalzeichen := 0;
number := 0.0;
p := ende + 1.
betrachte aktuelles zeichen:
zeichencode := code (source SUB p).
ziffer behandeln :
ziffer gefunden := TRUE;
number := (number + code to digit (zeichencode))/10.0;
vorkommastellen INCR 1.
dezimalzeichen behandeln :
dezimalzeichen := zeichencode;
vorkommastellen := 0.
wirkt als dezimalzeichen :
dezimalzeichen = 0 OR dezimalzeichen = zeichencode.
erlaubtes zeichen :
ziffer OR punkt OR komma OR pseudoblank vor ziffer.
pseudoblank vor ziffer :
zeichencode = pseudoblankcode AND pos (ziffern, source SUB (p+1) ) > 0.
vorzeichen : plus OR minus.
ziffer : zeichencode >= 48 AND zeichencode <= 57.
plus : zeichencode = 43.
minus : zeichencode = 45.
punkt : zeichencode = 46.
komma : zeichencode = 44.
ignorieren :.
END PROC pick up number;
PROC replace number (TEXT VAR source, REAL CONST value, INT CONST where,
nachkommastellen) :
alte grenzen feststellen;
wenn noetig auf format der neuen zahl erweitern;
zahl in text umwandeln;
zahl ersetzen.
alte grenzen feststellen :
REAL VAR dummy;
dummy := pick up number (source, where).
wenn noetig auf format der neuen zahl erweitern :
INT VAR schreibanfang := min (anfang, neuer anfang),
schreibende := max (ende, neues ende).
neuer anfang : where - vorkommazeichen + 1.
vorkommazeichen : max (2,(decimal exponent (value) + 2)).
neues ende : where + nachkommastellen + 1.
zahl in text umwandeln :
worktext := text (value,stellen,nachkommastellen);
IF decimal exponent (value) < 0 THEN
change (worktext," .","0."); change (worktext," -.","-0.");
FI;
IF nachkommastellen = 0 THEN
replace (worktext, LENGTH worktext, " ")
FI;
WHILE LENGTH worktext < schreibende-schreibanfang+1 REP
worktext CAT " "
PER.
zahl ersetzen :
WHILE LENGTH source < schreibende REP
source CAT " "
PER;
replace (source, schreibanfang, worktext) .
stellen : where-schreibanfang+2+nachkommastellen.
END PROC replace number;
END PACKET pick;
PACKET rechner DEFINES clear, push, result, do,
superklammer auf, superklammer zu,
empty, operand expected, dump:
(********************************************************************)
(* *)
(* Rechenwerk fuer TeCal 13.09.84 *)
(* *)
(********************************************************************)
LET plus = 1, minus = 2, mal = 3, durch = 4, hoch = 5,
monad minus = 6, klammer auf = 7, klammer zu = 8, gleich = 9;
LET klammerpriostufe = 10, superklammerpriostufe = 500;
LET tiefe = 30;
REAL VAR dummy;
BOOL VAR war operand;
INT VAR operandentop, operatorentop, klammerprio, superklammerprio;
ROW tiefe INT VAR operatorenstack;
ROW tiefe REAL VAR operandenstack;
PROC superklammer auf :
IF war operand THEN
pop (dummy)
FI;
superklammerprio INCR superklammerpriostufe;
klammerprio INCR superklammerpriostufe
END PROC superklammer auf;
PROC superklammer zu :
IF superklammerprio > 0 THEN
push (gleich);
superklammerprio DECR superklammerpriostufe;
klammerprio DECR superklammerpriostufe
FI;
END PROC superklammer zu;
INT PROC prio (INT CONST op):
klammer prio + elementar prio.
elementar prio :
SELECT op OF
CASE plus,minus : 2
CASE mal,durch : 3
CASE hoch : 4
CASE monadminus : 6
CASE klammerzu : 0
CASE gleich : -klammerprio+superklammerprio
OTHERWISE errorstop ("prio("+text(op)+")"); 0
END SELECT
END PROC prio;
PROC clear :
operandentop := 0;
operatorentop := 0;
war operand := FALSE;
klammerprio := 0;
superklammerprio := 0;
END PROC clear;
PROC push (INT CONST op) :
enable stop;
IF war operand THEN
dyadischer operator oder gleich oder klammer zu
ELIF op = minus COR op = monad minus THEN
push monadisches minus
ELIF op = plus THEN
(* ignoriere monad plus *)
ELIF op = klammer auf THEN
IF stack zu voll THEN
errorstop ("Zuviele offene Klammern")
FI;
klammerprio INCR klammerpriostufe
ELSE
errorstop ("Zahl erwartet, letzten Operator ignoriert")
FI.
dyadischer operator oder gleich oder klammer zu :
IF op = monad minus COR op = klammer auf THEN
(* errorstop ("Operator (+,-,*,/) vor Klammer auf fehlt")*)
ignore last operand;
push (op);
LEAVE push
ELSE
WHILE prio (op) <= stack top prio REPEAT
auswerten
PER;
push operator
FI.
stack top prio :
IF operatorentop = 0 THEN -1
ELSE operator DIV 10
FI.
stack zu voll :
operandentop >= tiefe - 4.
auswerten :
REAL VAR op2;
SELECT operator MOD 10 OF
CASE monad minus : operand := - operand
CASE plus : pop (op2); operand INCR op2
CASE minus: pop (op2); operand DECR op2
CASE mal : pop (op2); operand := operand * op2
CASE durch: pop (op2); operand := operand / op2
CASE hoch : pop (op2); operand := operand ** op2
OTHERWISE
(**) errorstop ("Im Opstack ("+text(operatorentop)+") gefunden : "+text(operator))
END SELECT;
war operand := TRUE;
operatorentop DECR 1.
push operator :
IF op = klammerzu THEN
IF klammerprio > superklammerprio THEN
klammerprio DECR klammerpriostufe (* ELSE ignoriere ")" zuviel *)
FI
ELIF op = gleich THEN
klammerprio := superklammerprio;
ELSE
operatorentop INCR 1;
operator := prio (op) * 10 + op;
war operand := FALSE
FI.
push monadisches minus :
operatorentop INCR 1;
operator := prio (monad minus) * 10 + monad minus.
ignore last operand :
pop (dummy).
END PROC push;
PROC push (REAL CONST op) :
IF war operand THEN
operand := op; (* Operand wird ueberschrieben *)
ELSE
operandentop INCR 1;
operand := op;
war operand := TRUE
FI
END PROC push;
PROC pop (REAL VAR r) :
IF operandentop = 0 THEN
errorstop ("Operand fehlt")
ELSE r := operand;
operandentop DECR 1
FI;
war operand := FALSE
END PROC pop;
REAL PROC result :
IF operanden top > 0 THEN operand ELSE 0.0 FI
END PROC result;
BOOL PROC empty :
operandentop < 1
END PROC empty;
BOOL PROC operand expected :
NOT war operand
END PROC operand expected;
PROC do (REAL PROC (REAL CONST) f):
IF NOT war operand THEN
push (f(result))
ELSE
operand := f(operand)
FI
END PROC do;
PROC dump :
INT VAR x,y;
get cursor (x,y);
cursor (1,1);
INT VAR i;
put(operatorentop);put ("OPERATOREN");
FOR i FROM 1 UPTO operatorentop REP
put (text (operatorenstack(i),8));
PER;out (""5""); line;
put (operandentop);put ("OPERANDEN ");
FOR i FROM 1 UPTO operandentop REP
put (text (operandenstack(i),8,2));
PER;out (""5""); line;
put ("Klammern:");put(klammerprio);
put ("Superklammern:");put(superklammerprio);
IF war operand THEN put ("war operand") ELSE put ("war operator") FI;line;
cursor (x,y);
END PROC dump;
.
operand : operandenstack (operandentop).
operator: operatorenstack(operatorentop).
END PACKET rechner;
PACKET tecalfunctions DEFINES merke, prozentsatz, kommastellen,
prozent, evaluate, tecal :
(********************************************************************)
(* *)
(* TeCal - Funktionen 15.09.84 *)
(* *)
(********************************************************************)
LET operatorenliste = "+-*/^ ()=", gib ausdruck = ""15" gib wert : ";
REAL VAR speicher := 0.0, percent := 14.0, displayed value := -1.0;
INT VAR nachkommastellen := 2;
INT VAR zeiger,dachpos; (* fuer evaluate *)
TEXT VAR char; (* fuer evaluate *)
TEXT VAR status line, anzeigetext;
INT VAR anzeigestart, anzeigelaenge, memorystart, prozentstart;
init status line;
PROC evaluate (TEXT CONST formel):
evaluate (formel,1)
END PROC evaluate;
PROC evaluate (TEXT CONST formel, INT CONST ab wo):
enable stop;
zum formelanfang;
REP
zum naechsten relevanten zeichen;
IF formelende THEN LEAVE evaluate
FI;
symbol verarbeiten
UNTIL gleich zeichen verarbeitet PER.
zum formelanfang :
dachpos := pos (formel,"^");
zeiger:= ab wo - 1.
zum naechsten relevanten zeichen :
REP
zum naechsten wahrscheinlich relevanten zeichen
UNTIL formelende COR wirklich relevant PER.
zum naechsten wahrscheinlich relevanten zeichen:
zeiger := pos (formel,"%","=",zeiger+1);
IF dachpos <> 0 CAND zeiger > dachpos THEN
zeiger := dachpos;
dachpos := pos (formel,"^",dachpos+1)
FI.
formelende :
zeiger = 0.
wirklich relevant :
char := formel SUB zeiger;
pos ("',.:;<", char) = 0.
symbol verarbeiten :
IF ziffer THEN
push (abs(pick up number(formel,zeiger)));
zeiger := right range
ELSE
INT VAR op := pos (operatorenliste,char);
IF op > 0 THEN
push (op)
ELIF char = "%" THEN
do (REAL PROC (REAL CONST) prozent)
ELSE errorstop ("TeCal FEHLER : symbol verarbeiten")
FI
FI.
gleichzeichen verarbeitet : char = "=".
ziffer : pos ("0123456789",char) > 0.
END PROC evaluate;
PROC merke (REAL CONST wert) :
speicher := wert;
set anzeigetext (speicher);
replace (statusline,memorystart,anzeigetext);
show status line
END PROC merke;
PROC merke (INT CONST wert) :
merke (real (wert));
END PROC merke;
PROC prozentsatz (REAL CONST wert) :
percent := wert;
replace (statusline,prozentstart,text(percent,6,2));
show status line;
END PROC prozentsatz;
PROC prozentsatz (INT CONST wert) :
prozentsatz (real (wert));
END PROC prozentsatz;
PROC kommastellen (INT CONST anz stellen) :
nachkommastellen := max ( 0, min (anz stellen, 16)) ;
set anzeigetext (0.0);
replace (statusline,anzeigestart,anzeigetext);
merke (speicher);
END PROC kommastellen;
REAL PROC prozent (REAL CONST wovon) :
percent * wovon / 100.0
END PROC prozent;
REAL PROC runden (REAL CONST was) :
round (was,nachkommastellen)
END PROC runden;
PROC init status line :
statusline :=
"$Anzeige: & __________._________ $ %%%.%%% Memory: ----------.--------- &"
; change all (statusline,"$",""15"");
change all (statusline,"&",""14"");
anzeigestart := pos (statusline,"_");
anzeigelaenge:= pos (statusline," ",anzeigestart)-anzeigestart;
memorystart := pos (statusline,"-");
prozentstart := pos (statusline,"%");
set anzeigetext (0.0);
replace (statusline,anzeigestart,anzeigetext);
set anzeigetext (speicher);
replace (statusline,memorystart,anzeigetext);
replace (statusline,prozentstart,text(percent,6,2))
END PROC init status line;
PROC show status line :
cursor (1,y screen size); out (statusline);
displayed value := 0.0;
display value
END PROC show status line;
PROC display value :
IF displayed value <> result THEN
cursor (anzeigestart,y screen size);
set anzeigetext (result);
out (anzeigetext)
FI.
END PROC display value;
PROC get expression (TEXT VAR exp) :
cursor (1,yscreen size);
out (gib ausdruck);
(x screen size - 4 - LENGTH gib ausdruck) TIMESOUT " ";
out (""14""15""8" ");
cursor (LENGTH gib ausdruck, y screen size);
editget (exp);
END PROC get expression;
PROC set anzeigetext (REAL CONST r) :
IF decimal exponent (r) + nachkommastellen + 3 <= anzeigelaenge THEN
anzeigetext := text (r,anzeigelaenge,nachkommastellen);
IF decimal exponent (r) < 0 THEN
change (anzeigetext," .","0."); change (anzeigetext," -.","-0.");
FI;
IF nachkommastellen = 0 THEN
replace (anzeigetext, LENGTH anzeigetext, " ")
FI;
ELSE
anzeigetext := text (r,anzeigelaenge)
FI
END PROC set anzeigetext;
(*************** TeCal - Editor - Schnittstelle *****************)
LET tecal tasten = "tq%()*+-/=CEFHKLMNRSVW^T"9"?",
funktionenliste = "LSCEFHKMNRVWtq%"9"T?" ,
zahlzeichen = "1234567890.,-+" ,
std tasten = "tqevw19dpgn"9"" ;
LET kommando prozent = 15,
kommando clear = 3,
kommando einlesen = 4,
kommando formel = 5,
kommando recall = 7,
kommando lesen = 1,
kommando store = 8,
kommando naechste = 9,
kommando q = 14,
kommando runden = 10,
kommando schreiben= 2,
kommando umschalt = 13,
kommando ver sum = 11,
kommando fenster = 12,
kommando type = 17,
kommando help = 18;
LET x screen size = 79,
y screen size = 24;
FILE VAR tecal file;
TEXT VAR record, input buffer;
INT VAR record pos;
PROC dateizeile lesen :
set busy indicator;
read record (tecal file, record);
record pos := col (tecal file)
END PROC dateizeile lesen;
PROC zahl aufsammeln :
dateizeile lesen;
REAL VAR zahl := pick up number (record, record pos);
IF last pick up ok THEN
push (zahl)
ELSE
errorstop ("Keine Zahl gefunden")
FI
END PROC zahl aufsammeln;
REAL PROC spaltensumme :
anfangsposition merken;
nach oben laufen und addieren;
zum anfang zurueck;
summe.
nach oben laufen und addieren :
WHILE NOT oben angekommen REP
hochgehen und satz lesen;
record auswerten
PER.
anfangsposition merken :
INT VAR alte zeile := line no (tecal file);
dateizeile lesen;
REAL VAR summe := pick up number (record,record pos);
BOOL VAR weiterlaufen := TRUE
IF NOT last pick up ok THEN
summe := 0.0
FI.
zum anfang zurueck :
to line (tecalfile, alte zeile).
hochgehen und satz lesen :
up (tecal file);
read record (tecal file, record).
oben angekommen : line no (tecalfile) = 1 COR NOT weiterlaufen.
record auswerten :
IF blankzeile THEN
weiterlaufen := TRUE
ELIF kein zahlzeichen THEN
weiterlaufen := FALSE
ELSE
summe INCR pick up number (record,record pos);
weiterlaufen := last pick up ok
FI.
blankzeile : LENGTH record < record pos COR (record SUB record pos) = " ".
kein zahlzeichen : pos (zahlzeichen,record SUB recordpos) = 0.
END PROC spaltensumme;
PROC tecal (TEXT CONST filename) :
type (""27"t");
edit (filename).
END PROC tecal;
PROC tecal :
IF groesster editor > 0
THEN tecal auf editfile
ELSE tecal (lastparam)
FI.
tecal auf editfile :
FILE VAR f := editfile;
quit;
tecal (f) .
END PROC tecal;
PROC tecal (FILE VAR ed file) :
enable stop ;
open editor (groesster editor + 1, ed file, TRUE,
1, 1, x screen size, y screen size - 1);
show status line;
edit (groesster editor, tecal tasten + std tasten,
PROC (TEXT CONST) tecal interpreter) .
END PROC tecal;
PROC tecal interpreter (TEXT CONST symbol) :
tecal file := editfile ;
nichts neu ;
INT VAR kommando := pos (operatorenliste,symbol);
IF kommando > 0 THEN
normale rechenoperation
ELSE kommando := pos (funktionenliste,symbol);
sonderfunktion
FI.
normale rechenoperation :
IF operand expected CAND keine klammer auf THEN
zahl aufsammeln
FI;
push (kommando);
display value.
keine klammer auf : symbol <> "(".
sonderfunktion :
SELECT kommando OF
CASE kommando prozent : do prozent
CASE kommando clear : do clear
CASE kommando einlesen : do get
CASE kommando formel : do formelrechnung
CASE kommando ver sum : do spaltensumme
CASE kommando recall : do speicher lesen
CASE kommando lesen : do zahl aufsammeln
CASE kommando store : do speicher schreiben
CASE kommando naechste : do zur naechsten zahl
CASE kommando q : quit
CASE kommando runden : do runden
CASE kommando schreiben: do schreiben
CASE kommando umschalt : do tecal abschalten
CASE kommando type : do type displayed value
(* CASE kommando hor sum : calculate ver sum*)
CASE kommando fenster : do fenster als zweiten operanden
(* CASE kommando tab : calculate tab sum *)
CASE kommando help : do ("tecal auskunft")
OTHERWISE : std kommando interpreter (symbol)
END SELECT.
do prozent :
IF operand expected THEN
zahl aufsammeln
FI;
do (REAL PROC (REAL CONST) prozent);
display value.
do clear :
clear;
ueberschrift neu;
show status line.
do get :
input buffer := "";
get expression (input buffer);
IF input buffer > " " THEN
disable stop;
superklammer auf;
evaluate (input buffer);
superklammer zu;
show status line;
enable stop;
ELSE
show status line
FI.
do zahl aufsammeln :
zahl aufsammeln;
display value.
do speicher schreiben :
merke (result);
show status line.
do type displayed value :
set anzeigetext (result);
push(compress(anzeigetext)).
do speicher lesen :
push (speicher);
display value.
do spaltensumme :
push (spaltensumme);
display value.
do formelrechnung :
dateizeile lesen;
disable stop;
superklammer auf;
evaluate (record);
superklammer zu;
enable stop;
display value;
IF enthaelt gleichzeichen CAND NOT empty THEN
ergebnis dahinter schreiben
ELSE
col (LENGTH record + 1)
FI.
enthaelt gleichzeichen :
INT VAR gleichpos := pos (record,"=");
gleichpos > 0.
ergebnis dahinter schreiben :
record pos := gleichpos + 2 + decimal exponent (result);
gleich pos := pos (record, ".", recordpos + 1) -1;
IF gleichpos > 0 THEN
record pos := gleichpos
FI;
ergebnis eintragen und dateizeile zurueckschreiben.
ergebnis eintragen und dateizeile zurueckschreiben :
replace number (record, result, record pos, nachkommastellen);
write record (tecal file, record);
zeile neu;
col (record pos).
do zur naechsten zahl :
dateizeile lesen;
record pos := pos (record,"0","9",record pos);
IF record pos = 0 THEN
record pos := LENGTH record + 1
FI;
col (record pos).
do schreiben :
IF NOT empty THEN
dateizeile lesen;
ergebnis eintragen und dateizeile zurueckschreiben
FI.
do runden :
IF NOT empty AND NOT operand expected THEN
do (REAL PROC (REAL CONST) runden)
FI.
do fenster als zweiten operanden :
IF empty THEN
push (0.0)
ELSE
push (result)
FI.
do tecal abschalten :
quit;
edit (tecalfile).
END PROC tecal interpreter;
clear;
kommando auf taste legen ("t","tecal");
(*kommando auf taste legen ("?","tecalauskunft");*)
END PACKET tecal functions;