home *** CD-ROM | disk | FTP | other *** search
/ BCI NET 2 / BCI NET 2.iso / archives / programming / e / amigae30a_fr.lha / AmigaE30f / Sources / Gfx / RewriteGfx.e < prev    next >
Encoding:
Text File  |  1994-02-21  |  4.6 KB  |  129 lines
  1. /* Utilisant un script de description d'image (de type Forth)
  2.    pour afficher des graphiques récursivement (tortues)
  3.  
  4.    Proche des grammaires normales de type s->ASA,
  5.    les commandes tortues (de type forth) suivantes peuvent être utilisés :
  6.  
  7.    up                 stylo levé
  8.    down               stylo baissé
  9.    <x> <y> set        fixe la position absolue
  10.    <d> move           déplace relativement a partir des dernières coordonnées
  11.                       d'un distance <d> en direction del'<angle>,
  12.                       trace une ligne si le stylo est baissé
  13.    <angle> degr       fixe l'angle initial
  14.    <angle> rol        tourne relativement dans le sens contraires
  15.                       des aiguilles d'une montre (gauche)
  16.    <angle> rol        tourne relativement dans le sens des aiguilles
  17.                       d'une montre (droite)
  18.    <nr> col           fixe la couleur
  19.    push               sauve l'état de x/y/angle/stylo à ce point sur le pile
  20.    pop                restaure létat
  21.    dup                double le dernier contenu sur la pile
  22.    <int> <int> add    additionne 2 entiers
  23.    <int> <int> sub    soustrait 2 entiers (premier - second)
  24.    <int> <int> mul    multiplie 2 entiers
  25.    <int> <int> div    divise 2 entiers
  26.    <int> <int> eq     regarde si 2 entiers sont égaux
  27.    <int> <int> uneq   regarde si 2 entiers sont inégaux
  28.    <bool> if <s> end  condition
  29.  
  30.    Traduction : Olivier ANH (BUGSS)   */
  31.  
  32. CONST CURGR=0     /* FIXEZ CECI A 0-2 POUR D'AUTRES GRAMMAIRES */
  33.  
  34. MODULE 'MathTrans'
  35.  
  36. ENUM S=1000, A,B,C,D,E,F,G, Z
  37. CONST R=20
  38.  
  39. DEF gr[10]:ARRAY OF LONG,win,stack[5000]:ARRAY OF LONG,sp=NIL:PTR TO LONG,
  40.     penf=TRUE,x=50.0,y=60.0,col=2,degr=0.0
  41.  
  42. /* ne construisez pas votre propre gramaire, si vous ne savez pas exactement
  43.    ce que vous faites. Il n'y a pas de vérification d'erreurs. */
  44.  
  45. PROC initgrammar()
  46.   gr[0]:=[[S,   A,A,A],                               /* lotsa triangles */
  47.           [A,   25,"ror",D,D,D,D,D,D,"up",50,"move","down"],
  48.           [D,   F,G,F,G,F,G,E],
  49.           [E,   "up",R,"move",30,"rol",5,"move",30,"rol","down"],
  50.           [F,   R,"move"],
  51.           [G,   120,"rol"]]
  52.   gr[1]:=[[S,   100,20,"set",30,A],                   /* shell */
  53.           [A,   "dup","move",1,"sub","dup",0,"uneq","if",B,"end"],
  54.           [B,   "dup","dup",90,"ror","move",180,"ror","up","move",
  55.                 90,"ror","down",20,"ror",A]]          /* quelques figures */
  56.   gr[2]:=[[S,   B,B,B,B,B,B,B,B,B,B,B,B,B,B,B],
  57.           [B,   A,A,A,A,A,A,A,A,-10,"move"],
  58.           [A,   "down",80,"move",183,"rol"]]
  59. ENDPROC
  60.  
  61. PROC main()
  62.   mathtransbase:=OpenLibrary('mathtrans.library',0)
  63.   IF mathtransbase=NIL
  64.     WriteF('Ne peut ouvrir la "mathtrans.library".\n')
  65.   ELSE
  66.     win:=OpenW(20,20,600,200,$200,$F,'Rewrite Graphics',NIL,1,NIL)
  67.     IF win=NIL
  68.       WriteF('Ne peut ouvrir la fenêtre !\n')
  69.     ELSE
  70.       initgrammar()
  71.       sp:=stack+400      /* temp */
  72.       dorewrite(S)
  73.       IF sp<>(stack+400) THEN WriteF('ATTENTION : la pile n''est pas propre\n')
  74.       WaitIMessage(win)
  75.       CloseW(win)
  76.     ENDIF
  77.     CloseLibrary(mathtransbase)
  78.   ENDIF
  79. ENDPROC
  80.  
  81. PROC dorewrite(startsym)
  82.   DEF i:PTR TO LONG
  83.   ForAll({i},gr[CURGR],`IF i[0]=startsym THEN dolist(i) ELSE 0)
  84. ENDPROC
  85.  
  86. PROC dolist(list:PTR TO LONG)
  87.   DEF r=1,sym,rada,cosa,sina,xd,yd,xo,yo,a
  88.   WHILE r<ListLen(list)
  89.     sym:=list[r++]
  90.     IF sym<S
  91.       sp[]++:=sym
  92.     ELSE
  93.       IF sym>Z
  94.         SELECT sym
  95.           CASE "down"; penf:=TRUE
  96.           CASE "up";   penf:=FALSE
  97.           CASE "set";  y:=sp[]--|; x:=sp[]--|
  98.           CASE "col";  col:=sp[]--
  99.           CASE "rol";  degr:=sp[]--|+degr
  100.           CASE "ror";  degr:=-sp[]--|+degr
  101.           CASE "degr"; degr:=sp[]--|
  102.           CASE "push"; sp[]++:=x; sp[]++:=y; sp[]++:=degr; sp[]++:=penf
  103.           CASE "pop";  sp[]--:=penf; sp[]--:=degr; sp[]--:=y; sp[]--:=x
  104.           CASE "dup";  a:=sp[]--; sp[]++:=a; sp[]++:=a
  105.           CASE "add";  sp[]++:=sp[]--+sp[]--
  106.           CASE "sub";  a:=sp[]--; sp[]++:=sp[]---a
  107.           CASE "mul";  sp[]++:=sp[]--*sp[]--
  108.           CASE "div";  a:=sp[]--; sp[]++:=sp[]--/a
  109.           CASE "eq";   sp[]++:=sp[]--=sp[]--
  110.           CASE "uneq"; sp[]++:=sp[]--<>sp[]--
  111.           CASE "end";  NOP
  112.           CASE "if";   IF sp[]--=FALSE THEN WHILE list[r++]<>"end" DO NOP
  113.           CASE "move"
  114.             xo:=x; yo:=y; x:=sp[]--|+x
  115.             rada:=|degr/180.0*3.14159
  116.             cosa:=SpCos(rada); sina:=SpSin(rada)
  117.             xd:=|x-xo; yd:=|y-yo
  118.             x:=|xo+(xd*cosa)-(yd*sina)
  119.             y:=|yo+(yd*cosa)-(xd*sina)
  120.             IF penf THEN Line(|xo|*2,|yo|,|x|*2,|y|,col)
  121.           DEFAULT; WriteF('ATTENTION : opcode inconnu\n')
  122.         ENDSELECT
  123.       ELSE
  124.         dorewrite(sym)
  125.       ENDIF
  126.     ENDIF
  127.   ENDWHILE
  128. ENDPROC
  129.