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