home *** CD-ROM | disk | FTP | other *** search
/ The CDPD Public Domain Collection for CDTV 3 / CDPDIII.bin / bbs / ff810.lha / FF810 / Amiga_E / Sources / Projects / RewriteGfx.e < prev    next >
Text File  |  1993-01-24  |  4KB  |  124 lines
  1. /* Using a (forth-featured) rewrite-grammar to plot 
  2.    recursive (turtle) graphics
  3.  
  4.    next to normal context-free grammars like S->ASA,
  5.    following (forth-lookalike) turtle commands may be used:
  6.  
  7.    up                 pen up
  8.    down               pen down
  9.    <x> <y> set        set absolute position
  10.    <d> move           move relative to last coordinates, distance <d>
  11.                       in direction <angle>, draw line if pen is down
  12.    <angle> degr       set initial angle
  13.    <angle> rol        rotate relative counter-clockwise (left)
  14.    <angle> rol        rotate relative clockwise (right)
  15.    <nr> col           set colour to plot with
  16.    push               save x/y/angle/pen status at this point on stack
  17.    pop                restore status
  18.    dup                duplicate last item on stack
  19.    <int> <int> add    add two integers
  20.    <int> <int> sub    substract two integers (first-second)
  21.    <int> <int> mul    multiply two integers
  22.    <int> <int> div    divide two integers
  23.    <int> <int> eq     see if two integers are equal
  24.    <int> <int> uneq   see if two integers are unequal
  25.    <bool> if <s> end  conditional statement           */
  26.  
  27. CONST CURGR=0     /* SET THIS ONE TO 0-2 TO GET A DIFFERENT GRAMMAR */
  28.  
  29. MODULE 'MathTrans'
  30.  
  31. ENUM S=1000, A,B,C,D,E,F,G, Z
  32. CONST R=20
  33.  
  34. DEF gr[10]:ARRAY OF LONG,win,stack[5000]:ARRAY OF LONG,sp=NIL:PTR TO LONG,
  35.     penf=TRUE,x=50.0,y=60.0,col=2,degr=0.0
  36.  
  37. /* don't build your own grammars if you don't know *exactly* what
  38.    you're doing. there are no error checks. */
  39.  
  40. PROC initgrammar()
  41.   gr[0]:=[[S,   A,A,A],                               /* lotsa triangles */
  42.           [A,   25,"ror",D,D,D,D,D,D,"up",50,"move","down"],
  43.           [D,   F,G,F,G,F,G,E],
  44.           [E,   "up",R,"move",30,"rol",5,"move",30,"rol","down"],
  45.           [F,   R,"move"],
  46.           [G,   120,"rol"]]
  47.   gr[1]:=[[S,   100,20,"set",30,A],                   /* shell */
  48.           [A,   "dup","move",1,"sub","dup",0,"uneq","if",B,"end"],
  49.           [B,   "dup","dup",90,"ror","move",180,"ror","up","move",
  50.                 90,"ror","down",20,"ror",A]]          /* some figure */
  51.   gr[2]:=[[S,   B,B,B,B,B,B,B,B,B,B,B,B,B,B,B],
  52.           [B,   A,A,A,A,A,A,A,A,-10,"move"],
  53.           [A,   "down",80,"move",183,"rol"]]
  54. ENDPROC
  55.  
  56. PROC main()
  57.   mathtransbase:=OpenLibrary('mathtrans.library',0)
  58.   IF mathtransbase=NIL
  59.     WriteF('Could not open "mathtrans.library".\n')
  60.   ELSE
  61.     win:=OpenW(20,20,600,200,$200,$F,'Rewrite Graphics',NIL,1,NIL)
  62.     IF win=NIL
  63.       WriteF('Could not open window!\n')
  64.     ELSE
  65.       initgrammar()
  66.       sp:=stack+400      /* temp */
  67.       dorewrite(S)
  68.       IF sp<>(stack+400) THEN WriteF('WARNING: stack not clean\n')
  69.       WaitIMessage(win)
  70.       CloseW(win)
  71.     ENDIF
  72.     CloseLibrary(mathtransbase)
  73.   ENDIF
  74. ENDPROC
  75.  
  76. PROC dorewrite(startsym)
  77.   DEF i:PTR TO LONG
  78.   ForAll({i},gr[CURGR],`IF i[0]=startsym THEN dolist(i) ELSE 0)
  79. ENDPROC
  80.  
  81. PROC dolist(list:PTR TO LONG)
  82.   DEF r=1,sym,rada,cosa,sina,xd,yd,xo,yo,a
  83.   WHILE r<ListLen(list)
  84.     sym:=list[r++]
  85.     IF sym<S
  86.       sp[]++:=sym
  87.     ELSE
  88.       IF sym>Z
  89.         SELECT sym
  90.           CASE "down"; penf:=TRUE
  91.           CASE "up";   penf:=FALSE
  92.           CASE "set";  y:=sp[]--|; x:=sp[]--|
  93.           CASE "col";  col:=sp[]--
  94.           CASE "rol";  degr:=sp[]--|+degr
  95.           CASE "ror";  degr:=-sp[]--|+degr
  96.           CASE "degr"; degr:=sp[]--|
  97.           CASE "push"; sp[]++:=x; sp[]++:=y; sp[]++:=degr; sp[]++:=penf
  98.           CASE "pop";  sp[]--:=penf; sp[]--:=degr; sp[]--:=y; sp[]--:=x
  99.           CASE "dup";  a:=sp[]--; sp[]++:=a; sp[]++:=a
  100.           CASE "add";  sp[]++:=sp[]--+sp[]--
  101.           CASE "sub";  a:=sp[]--; sp[]++:=sp[]---a
  102.           CASE "mul";  sp[]++:=sp[]--*sp[]--
  103.           CASE "div";  a:=sp[]--; sp[]++:=sp[]--/a
  104.           CASE "eq";   sp[]++:=sp[]--=sp[]--
  105.           CASE "uneq"; sp[]++:=sp[]--<>sp[]--
  106.           CASE "end";  NOP
  107.           CASE "if";   IF sp[]--=FALSE THEN WHILE list[r++]<>"end" DO NOP
  108.           CASE "move"
  109.             xo:=x; yo:=y; x:=sp[]--|+x
  110.             rada:=|degr/180.0*3.14159
  111.             cosa:=SpCos(rada); sina:=SpSin(rada)
  112.             xd:=|x-xo; yd:=|y-yo
  113.             x:=|xo+(xd*cosa)-(yd*sina)
  114.             y:=|yo+(yd*cosa)-(xd*sina)
  115.             IF penf THEN Line(|xo|*2,|yo|,|x|*2,|y|,col)
  116.           DEFAULT; WriteF('WARNING: unknown opcode\n')
  117.         ENDSELECT
  118.       ELSE
  119.         dorewrite(sym)
  120.       ENDIF
  121.     ENDIF
  122.   ENDWHILE
  123. ENDPROC
  124.