(*---------------------------------------------------------------------------
   :Program.    Kurve
   :Author.     Jörg Wesemann
   :Address.    Auf der Heide 10, 2807 Achim - Baden
   :Phone.      (0)4202 / 70658
   :Shortcut.   [jwe]
   :Version.    2.94
   :Date.       23.03.89
   :Copyright.  PD
   :Language.   Modula-II
   :Translator. M2Amiga
   :Imports.    none.
   :Update.     none.
   :Contents.   Parser für binäre Funktionen
   :Remark.     Das ! (NOT) muß in jedem Fall geklammert werden z.B.: !(a)
---------------------------------------------------------------------------*)


IMPLEMENTATION MODULE bparser;

FROM SYSTEM 		IMPORT  ADR;
FROM InOut 		IMPORT  Write,ReadString,WriteLn,WriteString,WriteCard,
				ReadCard,Read,CloseOutput;
FROM Strings 		IMPORT 	Occurs,first,last,Length;
FROM Arts 		IMPORT 	Assert,Error,BreakPoint;
FROM startupproc	IMPORT	center,crlf,wptr,cursorr,CLS,dateiabfrage,
				fragedatei,STRING;
FROM imagedata		IMPORT	CopyToChip,okimagedata,okhimagedata,oksize,
 				okhsize,CARDPTR;
FROM menu		IMPORT	wartemenu; 				
FROM Intuition 		IMPORT 	ScreenFlags,ScreenFlagSet,NewWindow,WindowPtr,
		      		IDCMPFlags,IDCMPFlagSet,WindowFlags,strGadget,
                                WindowFlagSet,OpenWindow,CloseWindow,Border,
                                IntuiMessage,Gadget,GadgetFlags,GadgetFlagSet,
                                ActivationFlags,boolGadget,ActivationFlagSet,
                                StringInfo,IntuiText,Image,WindowToFront;
FROM Graphics 		IMPORT 	Text,Move,jam1,RastPortPtr,Draw,SetAPen;
FROM Exec 		IMPORT 	GetMsg,ReplyMsg,WaitPort,FreeMem,UByte;


PROCEDURE bparser();

CONST
  NULL		=	"å";
  TOKSIZE	=	20;
  EXPRSSIZE	=	90;
  MAXVARS	=	5;

VAR
  argnum,arglen,lauf 			: INTEGER;
  argument,exprs,name,UndoBuffer	: STRING;
  ans,now,varzahl,i,in1,in2,help	: CARDINAL; 
  res					: ARRAY [0..MAXVARS-1] OF CARDINAL;
  varnames,undovarnames			: ARRAY [0..MAXVARS-1],[0..2] OF CHAR;
  antwort				: ARRAY [0..10] OF CHAR;
  class					: IDCMPFlagSet ;
  IntuiMsg    				: POINTER TO IntuiMessage ;
  myintuitext				: IntuiText ;
  gad	 				: ARRAY [0..6] OF Gadget ;
  Info 					: ARRAY [0..5] OF StringInfo ;
  Rahmen,Rahmen2			: Border;
  xyFeld,xyFeld2			: ARRAY [0..9]  OF INTEGER ;
  rp					: RastPortPtr;
  MyWindowPtr				: WindowPtr;
  MyWindow				: NewWindow;
  ok,okh				: Image;
  imageptr,himageptr			: CARDPTR;
  
PROCEDURE rand(rast: RastPortPtr; x,y,dx,dy: INTEGER);
BEGIN
  Move(rast,x,y);
  Draw(rast,x+dx,y);
  Draw(rast,x+dx,y+dy);
  Draw(rast,x,y+dy);
  Draw(rast,x,y);
END rand;

PROCEDURE POW(a,b:CARDINAL):CARDINAL;
VAR
  help,index : CARDINAL;
BEGIN
  IF b<=0 THEN
    RETURN 1;
  ELSE
    help:= a;
    FOR index:= 1 TO b-1 DO
      a:= a*help;
    END;
  END;
  RETURN a;
END POW;


PROCEDURE or(a,b:CARDINAL):CARDINAL;
BEGIN
  IF (a=1) OR (b=1) THEN 
    RETURN 1;
  ELSE
    RETURN 0;
  END;
END or;

PROCEDURE exor(a,b:CARDINAL):CARDINAL;
BEGIN
  IF ( (a=1) OR (b=1) )  AND (a#b) THEN
    RETURN 1;
  ELSE
    RETURN 0;
  END;
END exor;


PROCEDURE nor(a,b:CARDINAL):CARDINAL;
BEGIN
  IF (a=1) OR (b=1) THEN 
    RETURN 0;
  ELSE
    RETURN 1;
  END;
END nor;


PROCEDURE and(a,b:CARDINAL):CARDINAL;
BEGIN
  IF (a=1) AND (b=1) THEN
    RETURN 1;
  ELSE
    RETURN 0;
  END;
END and;


PROCEDURE nand(a,b:CARDINAL):CARDINAL;
BEGIN
  IF (a=1) AND (b=1) THEN
    RETURN 0;
  ELSE
    RETURN 1;
  END;
END nand;


PROCEDURE not(a:CARDINAL):CARDINAL;
BEGIN
  IF (a=1) THEN
    RETURN 0;
  ELSE
    RETURN 1;
  END;
END not;


PROCEDURE binary(a,b:CARDINAL; tok: ARRAY OF CHAR):CARDINAL;
BEGIN
  CASE tok[0] OF
    "+": RETURN or(a,b)    |
    "%": RETURN exor(a,b)  |
    "*": RETURN and(a,b)   |
    "&": RETURN nand(a,b)  |
    "/": RETURN nor(a,b);  |
  ELSE
    Error(ADR("!   Operator nicht gefunden   !"),ADR("Nicht behebbar"));
  END;
END binary;


PROCEDURE stripleer;
BEGIN
  WHILE (exprs[now]=" ") DO
    INC(now);
  END;
END stripleer;


PROCEDURE getfn(VAR tok: ARRAY OF CHAR);
VAR
  toklauf : CARDINAL;
BEGIN
  FOR toklauf:= 0 TO TOKSIZE DO
    tok[toklauf]:=" ";
  END;
  toklauf:=0;
  stripleer;
  WHILE ( (exprs[now]>="A") AND (exprs[now]<="Z") OR (exprs[now]="!")  ) DO
     tok[toklauf]:=exprs[now];
     INC(toklauf);
     INC(now);
  END;
END getfn;



PROCEDURE getnumb(VAR tok: ARRAY OF CHAR);
VAR
  toklauf: CARDINAL;
BEGIN
  FOR toklauf:= 0 TO TOKSIZE DO
    tok[toklauf]:=" ";
  END;
  stripleer;
  toklauf:=0;
  WHILE 
  ( (exprs[now]>="0") AND (exprs[now]<="9") )  DO
    tok[toklauf]:= exprs[now];
    INC(toklauf);
    INC(now);
  END;
END getnumb;      


PROCEDURE gettoken(VAR tok: ARRAY OF CHAR);
VAR
  c: CHAR;
BEGIN
  stripleer;
  c:=exprs[now];
  IF 
( (c="+") OR (c="%") OR (c="*") OR (c="/") OR (c="&") OR (c=")") OR 
  (c="!")  ) THEN
    tok[0]:= exprs[now];
    INC(now);
  ELSE
    tok[0]:= NULL;
  END;
END gettoken;
  
PROCEDURE parse0():CARDINAL; FORWARD;


PROCEDURE parse5():CARDINAL;

VAR
  tok,zahlstr : ARRAY[0..TOKSIZE] OF CHAR;
  a : CARDINAL;
  err:BOOLEAN;
  toklen,index: CARDINAL;
  
PROCEDURE fneval():CARDINAL;
VAR 
  i : CARDINAL;
BEGIN
  FOR i:= 0 TO varzahl-1 DO
    IF tok[0]= CAP(varnames[i][0]) THEN
      RETURN res[i];
    END;
  END;
  IF tok[0]="!" THEN 
    RETURN ( not( parse5() )  );
  ELSE
    Error(ADR("! Funktion nicht implementiert !"),ADR("Nicht behebbar"));
  END;
END fneval;


BEGIN
  getfn(tok);
  IF tok[0]#" " THEN
    RETURN (fneval());
  END;
  getnumb(tok);
  IF tok[0]#" " THEN
    IF tok[0]="0" THEN
      RETURN 0;
    ELSE
      RETURN 1;
    END;
  END;
  IF (exprs[now]="(") THEN
    INC(now);
    a:= parse0();
    IF (exprs[now]=")") THEN
      INC(now);
    ELSE
      Error(ADR("!   Falscher Klammerausdruck   !"),ADR("Nicht behebbar"));
    END;
    RETURN a;
  END;
  Error(ADR("!  Ausdruck nicht erkannt  !"),ADR("Nicht behebbar"));
END parse5;


(*
PROCEDURE parse4():CARDINAL;
VAR
  tok : ARRAY [0..TOKSIZE] OF CHAR;
BEGIN
  gettoken(tok);
  IF (tok[0]="!") THEN
    RETURN (not(parse4()));
  ELSIF (tok[0]="+") THEN
    RETURN(parse4()); 
  ELSIF (tok[0]=NULL) THEN
    RETURN (parse5());
  END;
  DEC(now);
  RETURN(parse5());
END parse4;
*)
(*
PROCEDURE parse3():CARDINAL;
VAR
  tok: ARRAY [0..TOKSIZE] OF CHAR;
  a : CARDINAL;
BEGIN
  
  a:= parse4();
  WHILE (exprs[now]#NULL) DO
    gettoken(tok);
    IF (  (tok[0]="^") OR (tok[0]="&")  ) THEN
      a:= binary(a,parse4(),tok);
    ELSE
      DEC(now);
    END;
    RETURN a;
  END;
  RETURN a;
END parse3;
*)

PROCEDURE parse2():CARDINAL;
VAR
  tok: ARRAY [0..TOKSIZE] OF CHAR;
  a: CARDINAL;
BEGIN
  a:= parse5();
  WHILE (exprs[now]#NULL) DO
    gettoken(tok);
    IF ((tok[0]="*") OR (tok[0]="&")) THEN
      a:= binary(a,parse5(),tok);
    ELSE
      DEC(now);
      RETURN a;
    END;
  END;
  RETURN a;
END parse2;


PROCEDURE parse0():CARDINAL;
VAR
  tok : ARRAY [0..TOKSIZE] OF CHAR;
  a : CARDINAL;
BEGIN 
  a:= parse2();
  WHILE (exprs[now]#NULL) DO
    gettoken(tok);
    IF ( (tok[0]="+") OR (tok[0]="%") OR (tok[0]="/") ) THEN
      a:= binary(a,parse2(),tok);
    ELSE
      DEC(now);
      RETURN a;
    END;
  END;
  RETURN a;
END parse0;


BEGIN
  FOR i:= 0 TO MAXVARS - 1 DO
    varnames[i]:= "";
  END;
  argument := "";
  WindowToFront(wptr);
  Write(CLS);
  crlf(3);
  WITH MyWindow DO
    leftEdge:= 0; topEdge:= 0;       
    width:= 640; height:= 256;
    detailPen:= 0; blockPen:= 0;
    idcmpFlags:= IDCMPFlagSet{gadgetUp}; 
    flags:= WindowFlagSet{};  
    firstGadget:=  ADR(gad[0]);
    checkMark:= NIL;
    title:= ADR("Eingabe der Funktion");
    bitMap:= NIL;
    type:= ScreenFlagSet{wbenchScreen};
    minWidth:= 640; maxWidth:= 640;
    minHeight:= 256; maxHeight:= 256;     
  END;					(* WITH MyWindow	*)
   
  WITH Rahmen DO				
    leftEdge:= -1; topEdge:= -2;
    frontPen:= 1; backPen:= 0;
    drawMode:= jam1;
    count:= 5; xy:= ADR(xyFeld);
    nextBorder:= NIL;
  END;
  xyFeld[0]:= 0;   xyFeld[1]:= 0;
  xyFeld[2]:= 263; xyFeld[3]:= 0;
  xyFeld[4]:= 263; xyFeld[5]:= 11;
  xyFeld[6]:= 0;   xyFeld[7]:= 11;
  xyFeld[8]:= 0;   xyFeld[9]:= 0;
    
  WITH Rahmen2 DO				
    leftEdge:= -1; topEdge:= -2;
    frontPen:= 1; backPen:= 0;
    drawMode:= jam1;
    count:= 5; xy:= ADR(xyFeld2);
    nextBorder:= NIL;
  END;
  xyFeld2[0]:= 0;   xyFeld2[1]:= 0;
  xyFeld2[2]:= 31;  xyFeld2[3]:= 0;
  xyFeld2[4]:= 31;  xyFeld2[5]:= 11;
  xyFeld2[6]:= 0;   xyFeld2[7]:= 11;
  xyFeld2[8]:= 0;   xyFeld2[9]:= 0;
   
  UndoBuffer:= " ";
    
  WITH Info[5] DO
    buffer:= ADR(argument); undoBuffer:= ADR(UndoBuffer);
    bufferPos:= 0; maxChars:= 40; dispPos:= 0;
  END;
  FOR i:= 0 TO 4 DO
    WITH Info[i] DO
      buffer:= ADR(varnames[i][0]); undoBuffer:= ADR(undovarnames[i][0]);
      bufferPos:= 0; maxChars:= 2; dispPos:= 0;
    END;
  END;
    
  WITH gad[5] DO					(* gad 1		*)
    nextGadget:= ADR(gad[6]);
    leftEdge:= 220; topEdge:= 120;
    width:= 262; height:= 10;
    flags:= GadgetFlagSet{};
    activation:= ActivationFlagSet{toggleSelect,stringCenter};
    gadgetType:= strGadget;
    gadgetRender:= ADR(Rahmen); selectRender:= NIL; 
    gadgetText:= NIL; specialInfo:= ADR(Info[5]);
    gadgetID:= 5;
    userData:= NIL;
  END;
    
  FOR i:= 0 TO 4 DO
    WITH gad[i] DO					(* gad 1		*)
      nextGadget:= ADR(gad[i+1]);
      leftEdge:= 220+i*58; topEdge:= 135;
      width:= 30; height:= 10;
      flags:= GadgetFlagSet{};
      activation:= ActivationFlagSet{toggleSelect,stringCenter};
      gadgetType:= strGadget;
      gadgetRender:= ADR(Rahmen2); selectRender:= NIL; 
      gadgetText:= NIL; specialInfo:= ADR(Info[i]);
      gadgetID:= i;
      userData:= NIL;
    END;
  END;
   
  CopyToChip(ADR(okimagedata),imageptr,oksize);
  CopyToChip(ADR(okhimagedata),himageptr,okhsize);
  WITH ok DO
    leftEdge:= 0; topEdge:= 0; width:= 80; height:= 20; depth:=2;
    imageData:= imageptr; planePick:= 3; planeOnOff:= 0;
    nextImage:= NIL;
  END;
  WITH okh DO
    leftEdge:= 0; topEdge:= 0; width:= 80; height:= 20; depth:=2;
    imageData:= himageptr; planePick:= 3; planeOnOff:= 0;
    nextImage:= NIL;
  END;
   
  WITH gad[6] DO
    nextGadget:= NIL;
    leftEdge:= 280; topEdge:= 205;
    width:= 80; height:= 20;
    flags:= GadgetFlagSet{gadgImage,gadgHImage};
    activation:= ActivationFlagSet{gadgImmediate,relVerify};
    gadgetType:= boolGadget;
    gadgetRender:= ADR(ok); selectRender:= ADR(okh); 
    gadgetText:= NIL; specialInfo:= NIL;
    gadgetID:= 6;
    userData:= NIL;
  END;
    
  MyWindowPtr:= OpenWindow(MyWindow);
  Assert(MyWindowPtr # NIL, ADR("Fenster nicht geöffnet"));
  rp:= MyWindowPtr^.rPort;
  rand(rp,100,60,440,100);
  Move(rp,100,90); Draw(rp,540,90);
  Move(rp,210,79);
  Text(rp,ADR("E I N G A B E  der Funktion"),27);
  Move(rp,150,126);
  Text(rp,ADR("f(x) =  "),8);
  SetAPen(rp,2);
  rand(rp,104,62,432,26);
  rand(rp,104,92,432,66);
  SetAPen(rp,1);
  LOOP
    WaitPort(MyWindowPtr^.userPort); 
    IntuiMsg:= GetMsg(MyWindowPtr^.userPort);
    class:= IntuiMsg^.class;
    ReplyMsg(IntuiMsg);
    IF class=IDCMPFlagSet{gadgetUp} THEN
      EXIT;
    END;
  END;						(* LOOP 1	*)
  CloseWindow(MyWindowPtr);
  FreeMem(imageptr,oksize);
  FreeMem(himageptr,okhsize);
    
  arglen:= Length(argument);
  FOR lauf:= 0 TO arglen DO
    exprs[lauf+1]:= CAP(argument[lauf]);
  END;
  exprs[arglen+1]:=NULL;
  exprs[0]:= NULL;
  now:=1;
  varzahl:= 0;
  WHILE (CAP(varnames[varzahl][0]) >= 'A') AND 
        (CAP(varnames[varzahl][0]) <= 'Z') AND  (varzahl < MAXVARS) DO 
    INC(varzahl);
  END;
  IF dateiabfrage THEN
    fragedatei();
  END;
  center("WERTETABELLE DER BINÄREN FUNKTION"); WriteLn;
  center("---------------------------------"); WriteLn;
  cursorr( 18+(31-Length(argument)) DIV 2 );
  WriteString("f(..) = ");
  WriteString(argument); crlf(2);
  cursorr((69-2*varzahl) DIV 2);
  Write(' ');
  FOR i:= varzahl-1 TO 0 BY -1 DO
    Write(varnames[i][0]);
    Write(' ');
  END;
  WriteString("|  f");
  crlf(2);
  cursorr((69-2*varzahl) DIV 2);
  FOR in1:= 0 TO POW(2,varzahl)-1 DO
    now:= 1;
    help:=in1;
    FOR in2:= varzahl-1 TO 0 BY -1 DO;
      res[in2]:= help DIV POW(2,in2);
      help:= help MOD POW(2,in2);
    END;
    FOR in2:= varzahl-1 TO 0 BY -1 DO
      WriteCard(res[in2],2);
    END;
    WriteString(" | ");
    ans:= parse0();
    IF exprs[1]=NULL THEN
      center(" =  Bad expression.");
      WriteLn;
    END;
    WriteCard(ans,2);
    WriteLn;
    cursorr((69-2*varzahl) DIV 2);
  END; 
  crlf(3);
  CloseOutput;
  center("Bitte 'RETURN' drücken  ");
  wartemenu;
END bparser;
  
END bparser.