home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / E / TFF-A32R.LZX / AmigaE3.2a / Src / Gfx / RewriteGfx.e < prev    next >
Encoding:
Text File  |  1992-09-02  |  6.7 KB  |  170 lines
  1. /* Using a (forth-featured) rewrite-grammar to plot 
  2.    recursive (turtle) graphics
  3.  
  4.    a graphics plotting system that uses rewrite-grammars. the idea is
  5.    that the description of an image (much like some fractals i know)
  6.    is denoted in a grammar, which is then used to plot the gfx.
  7.    the system uses turtlegraphics for plotting, and some forth-heritage
  8.    for additional power. the program is not meant to actually "used";
  9.    change to different graphics with the CONST in the sources, to
  10.    see what the grammars do.
  11.  
  12.    next to normal context-free grammars like S->ASA,
  13.    following (forth-lookalike) turtle commands may be used:
  14.  
  15.    up                 pen up
  16.    down               pen down
  17.    <x> <y> set        set absolute position
  18.    <d> move           move relative to last coordinates, distance <d>
  19.                       in direction <angle>, draw line if pen is down
  20.    <angle> degr       set initial angle
  21.    <angle> rol        rotate relative counter-clockwise (left)
  22.    <angle> rol        rotate relative clockwise (right)
  23.    <nr> col           set colour to plot with
  24.    push               save x/y/angle/pen status at this point on stack
  25.    pop                restore status
  26.    dup                duplicate last item on stack
  27.    <int> <int> add    add two integers
  28.    <int> <int> sub    substract two integers (first-second)
  29.    <int> <int> mul    multiply two integers
  30.    <int> <int> div    divide two integers
  31.    <int> <int> eq     see if two integers are equal
  32.    <int> <int> uneq   see if two integers are unequal
  33.    <bool> if <s> end  conditional statement           */
  34.  
  35. CONST CURGR=9     /* SET THIS ONE TO 0-11 TO GET A DIFFERENT GRAMMAR */
  36.  
  37. ENUM S=1000, A,B,C,D,E,F,G, Z
  38. CONST R=20
  39.  
  40. DEF gr[20]:ARRAY OF LONG,win,stack[5000]:ARRAY OF LONG,sp=NIL:PTR TO LONG,
  41.     penf=TRUE,x=50.0,y=60.0,col=2,degr=0.0
  42.  
  43. /* don't build your own grammars if you don't know *exactly* what
  44.    you're doing. there are no error checks. */
  45.  
  46. PROC initgrammar()
  47.  
  48.   gr[0]:=[[S,   A,A,A],                               /* lotsa triangles */
  49.           [A,   25,"ror",D,D,D,D,D,D,"up",50,"move","down"],
  50.           [D,   F,G,F,G,F,G,E],
  51.           [E,   "up",R,"move",30,"rol",5,"move",30,"rol","down"],
  52.           [F,   R,"move"],
  53.           [G,   120,"rol"]]
  54.  
  55.   gr[1]:=[[S,   100,20,"set",30,A],                   /* shell */
  56.           [A,   "dup","move",1,"sub","dup",0,"uneq","if",B,"end"],
  57.           [B,   "dup","dup",90,"ror","move",180,"ror","up","move",
  58.                 90,"ror","down",20,"ror",A]]          /* some figure */
  59.  
  60.   gr[2]:=[[S,   B,B,B,B,B,B,B,B,B,B,B,B,B,B,B],
  61.           [B,   A,A,A,A,A,A,A,A,-10,"move"],
  62.           [A,   "down",80,"move",183,"rol"]]
  63.  
  64.  
  65.   gr[4]:=[[S,   160,188,"set",90,"degr",30,A,1,"col",1,"move"],   /* 45 tree */
  66.           [A,   "dup","dup","move","if","dup",115,"mul",150,"div","dup",45,
  67.                 "rol",A,90,"ror",A,45,"rol","end",180,"rol","move",180,"rol"]]
  68.  
  69.   gr[5]:=[[S,   160,188,"set",90,"degr",60,A,1,"col",1,"move"], /* thin tree */
  70.           [A,   "dup","dup","move","if","dup",100,"mul",150,"div","dup",40,
  71.                 "rol",A,69,"ror",196,"mul",191,"div",A,29,"rol","end",180,
  72.                 "rol","move",180,"rol"]]
  73.  
  74.   gr[6]:=[[S,   160,188,"set",91,"degr",36,A,1,"col",1,"move"], /* slow tree */
  75.           [A,   "dup","dup","move","if","dup",120,"mul",150,"div","dup",20,
  76.                 "rol",A,40,"ror",170,"mul",166,"div",A,20,"rol","end",180,
  77.                 "rol","move",180,"rol"]]
  78.  
  79.   gr[7]:=[[S,   200,160,"set",90,"degr",30,A,1,"col",1,"move"],/* swirl tree */
  80.           [A,   "dup","dup","move","if","dup",135,"mul",150,"div","dup",29,
  81.                 "rol",A,50,"ror",21,"mul",30,"div",A,21,"rol","end",180,
  82.                 "rol","move",180,"rol"]]
  83.  
  84.   gr[8]:=[[S,   160,160,"set",90,"degr",36,A,1,"col",1,"move"],   /* frond */
  85.           [A,   "dup","dup","move","if","dup",112,"mul",150,"div","dup",35,
  86.                 "rol",A,120,"ror",A,85,"rol","end",180,"rol","move",180,"rol"]]
  87.  
  88.   gr[9]:=[[S,   160,188,"set",90,"degr",32,A,1,"col",1,"move"], /* nice tree */
  89.           [A,   "dup","dup","move","if","dup",85,"mul",150,"div","dup","dup",
  90.                 25,"rol",A,25,"ror",150,"mul",100,"div",A,
  91.                 25,"ror",A,25,"rol","end",180,"rol","move",180,"rol"]]
  92.  
  93.   gr[10]:=[[S,   160,188,"set",90,"degr",60,A,1,"col",1,"move"],/* sahara */
  94.            [A,   "dup","dup","move","if","dup",95,"mul",150,"div","dup",15,
  95.                  "rol",A,30,"ror",A,15,"rol","end",180,"rol","move",180,"rol"]]
  96.  
  97.   gr[11]:=[[S,  134,188,"set",90,"degr",44,A,
  98.                 184,174,"set",94,"degr",36,A,
  99.                 158,191,"set",88,"degr",48,A,
  100.                 206,168,"set",90,"degr",14,A],   /* sea oats */
  101.            [A,  "dup","dup","move","if","dup",60,"mul",150,"div","dup",
  102.                 114,"rol",A,2,"mul",100,"ror",A,14,"ror","end",180,"rol",
  103.                 "move",180,"rol"]]
  104.     
  105.  
  106. ENDPROC
  107.  
  108. PROC main()
  109.   win:=OpenW(20,20,600,200,$200,$F,'Rewrite Graphics',NIL,1,NIL)
  110.   IF win=NIL
  111.     WriteF('Could not open window!\n')
  112.   ELSE
  113.     initgrammar()
  114.     sp:=stack+400      /* temp */
  115.     dorewrite(S)
  116.     IF sp<>(stack+400) THEN WriteF('WARNING: stack not clean\n')
  117.     WaitIMessage(win)
  118.     CloseW(win)
  119.   ENDIF
  120. ENDPROC
  121.  
  122. PROC dorewrite(startsym)
  123.   DEF i:PTR TO LONG
  124.   ForAll({i},gr[CURGR],`IF i[0]=startsym THEN dolist(i) ELSE 0)
  125. ENDPROC
  126.  
  127. PROC dolist(list:PTR TO LONG)
  128.   DEF r=1,sym,rada,cosa,sina,xd,yd,xo,yo,a
  129.   WHILE r<ListLen(list)
  130.     sym:=list[r++]
  131.     IF sym<S
  132.       sp[]++:=sym
  133.     ELSE
  134.       IF sym>Z
  135.         SELECT sym
  136.           CASE "down"; penf:=TRUE
  137.           CASE "up";   penf:=FALSE
  138.           CASE "set";  y:=sp[]--!; x:=sp[]--!
  139.           CASE "col";  col:=sp[]--
  140.           CASE "rol";  degr:=sp[]--!+degr
  141.           CASE "ror";  degr:=-sp[]--!+degr
  142.           CASE "degr"; degr:=sp[]--!
  143.           CASE "push"; sp[]++:=x; sp[]++:=y; sp[]++:=degr; sp[]++:=penf
  144.           CASE "pop";  sp[]--:=penf; sp[]--:=degr; sp[]--:=y; sp[]--:=x
  145.           CASE "dup";  a:=sp[]--; sp[]++:=a; sp[]++:=a
  146.           CASE "add";  sp[]++:=sp[]--+sp[]--
  147.           CASE "sub";  a:=sp[]--; sp[]++:=sp[]---a
  148.           CASE "mul";  sp[]++:=sp[]--*sp[]--
  149.           CASE "div";  a:=sp[]--; sp[]++:=sp[]--/a
  150.           CASE "eq";   sp[]++:=sp[]--=sp[]--
  151.           CASE "uneq"; sp[]++:=sp[]--<>sp[]--
  152.           CASE "end";  NOP
  153.           CASE "if";   IF sp[]--=FALSE THEN WHILE list[r++]<>"end" DO NOP
  154.           CASE "move"
  155.             xo:=x; yo:=y; x:=sp[]--!+x
  156.             rada:=!degr/180.0*3.14159
  157.             cosa:=Fcos(rada); sina:=Fsin(rada)
  158.             xd:=!x-xo; yd:=!y-yo
  159.             x:=!xo+(!xd*cosa)-(!yd*sina)
  160.             y:=!yo+(!yd*cosa)-(!xd*sina)
  161.             IF penf THEN Line(!xo!*2,!yo!,!x!*2,!y!,col)
  162.           DEFAULT; WriteF('WARNING: unknown opcode\n')
  163.         ENDSELECT
  164.       ELSE
  165.         dorewrite(sym)
  166.       ENDIF
  167.     ENDIF
  168.   ENDWHILE
  169. ENDPROC
  170.