/* Using a (forth-featured) rewrite-grammar to plot 
   recursive (turtle) graphics

   next to normal context-free grammars like S->ASA,
   following (forth-lookalike) turtle commands may be used:

   up                 pen up
   down               pen down
   <x> <y> set        set absolute position
   <d> move           move relative to last coordinates, distance <d>
                      in direction <angle>, draw line if pen is down
   <angle> degr       set initial angle
   <angle> rol        rotate relative counter-clockwise (left)
   <angle> rol        rotate relative clockwise (right)
   <nr> col           set colour to plot with
   push               save x/y/angle/pen status at this point on stack
   pop                restore status
   dup                duplicate last item on stack
   <int> <int> add    add two integers
   <int> <int> sub    substract two integers (first-second)
   <int> <int> mul    multiply two integers
   <int> <int> div    divide two integers
   <int> <int> eq     see if two integers are equal
   <int> <int> uneq   see if two integers are unequal
   <bool> if <s> end  conditional statement           */

CONST CURGR=0     /* SET THIS ONE TO 0-2 TO GET A DIFFERENT GRAMMAR */

MODULE 'MathTrans'

ENUM S=1000, A,B,C,D,E,F,G, Z
CONST R=20

DEF gr[10]:ARRAY OF LONG,win,stack[5000]:ARRAY OF LONG,sp=NIL:PTR TO LONG,
    penf=TRUE,x=50.0,y=60.0,col=2,degr=0.0

/* don't build your own grammars if you don't know *exactly* what
   you're doing. there are no error checks. */

PROC initgrammar()
  gr[0]:=[[S,   A,A,A],                               /* lotsa triangles */
          [A,   25,"ror",D,D,D,D,D,D,"up",50,"move","down"],
          [D,   F,G,F,G,F,G,E],
          [E,   "up",R,"move",30,"rol",5,"move",30,"rol","down"],
          [F,   R,"move"],
          [G,   120,"rol"]]
  gr[1]:=[[S,   100,20,"set",30,A],                   /* shell */
          [A,   "dup","move",1,"sub","dup",0,"uneq","if",B,"end"],
          [B,   "dup","dup",90,"ror","move",180,"ror","up","move",
                90,"ror","down",20,"ror",A]]          /* some figure */
  gr[2]:=[[S,   B,B,B,B,B,B,B,B,B,B,B,B,B,B,B],
          [B,   A,A,A,A,A,A,A,A,-10,"move"],
          [A,   "down",80,"move",183,"rol"]]
ENDPROC

PROC main()
  mathtransbase:=OpenLibrary('mathtrans.library',0)
  IF mathtransbase=NIL
    WriteF('Could not open "mathtrans.library".\n')
  ELSE
    win:=OpenW(20,20,600,200,$200,$F,'Rewrite Graphics',NIL,1,NIL)
    IF win=NIL
      WriteF('Could not open window!\n')
    ELSE
      initgrammar()
      sp:=stack+400      /* temp */
      dorewrite(S)
      IF sp<>(stack+400) THEN WriteF('WARNING: stack not clean\n')
      WaitIMessage(win)
      CloseW(win)
    ENDIF
    CloseLibrary(mathtransbase)
  ENDIF
ENDPROC

PROC dorewrite(startsym)
  DEF i:PTR TO LONG
  ForAll({i},gr[CURGR],`IF i[0]=startsym THEN dolist(i) ELSE 0)
ENDPROC

PROC dolist(list:PTR TO LONG)
  DEF r=1,sym,rada,cosa,sina,xd,yd,xo,yo,a
  WHILE r<ListLen(list)
    sym:=list[r++]
    IF sym<S
      sp[]++:=sym
    ELSE
      IF sym>Z
        SELECT sym
          CASE "down"; penf:=TRUE
          CASE "up";   penf:=FALSE
          CASE "set";  y:=sp[]--|; x:=sp[]--|
          CASE "col";  col:=sp[]--
          CASE "rol";  degr:=sp[]--|+degr
          CASE "ror";  degr:=-sp[]--|+degr
          CASE "degr"; degr:=sp[]--|
          CASE "push"; sp[]++:=x; sp[]++:=y; sp[]++:=degr; sp[]++:=penf
          CASE "pop";  sp[]--:=penf; sp[]--:=degr; sp[]--:=y; sp[]--:=x
          CASE "dup";  a:=sp[]--; sp[]++:=a; sp[]++:=a
          CASE "add";  sp[]++:=sp[]--+sp[]--
          CASE "sub";  a:=sp[]--; sp[]++:=sp[]---a
          CASE "mul";  sp[]++:=sp[]--*sp[]--
          CASE "div";  a:=sp[]--; sp[]++:=sp[]--/a
          CASE "eq";   sp[]++:=sp[]--=sp[]--
          CASE "uneq"; sp[]++:=sp[]--<>sp[]--
          CASE "end";  NOP
          CASE "if";   IF sp[]--=FALSE THEN WHILE list[r++]<>"end" DO NOP
          CASE "move"
            xo:=x; yo:=y; x:=sp[]--|+x
            rada:=|degr/180.0*3.14159
            cosa:=SpCos(rada); sina:=SpSin(rada)
            xd:=|x-xo; yd:=|y-yo
            x:=|xo+(xd*cosa)-(yd*sina)
            y:=|yo+(yd*cosa)-(xd*sina)
            IF penf THEN Line(|xo|*2,|yo|,|x|*2,|y|,col)
          DEFAULT; WriteF('WARNING: unknown opcode\n')
        ENDSELECT
      ELSE
        dorewrite(sym)
      ENDIF
    ENDIF
  ENDWHILE
ENDPROC