GMC: Grafische Meta-circulaire Scheme Evaluator, source

Inhoud

Inhoud................................................................................................................................................ 2

Begeleidend woordje....................................................................................................................... 3

Grafische routines............................................................................................................................ 4

Types................................................................................................................................. 4

Een aantal algemene routines......................................................................................... 4

Punten................................................................................................................................ 5

Rectangles......................................................................................................................... 6

Box...................................................................................................................................... 6

Text..................................................................................................................................... 7

Views.................................................................................................................................. 7

Colors................................................................................................................................. 8

Cirkels................................................................................................................................. 8

Init & done........................................................................................................................ 8

Grafische Layout.............................................................................................................................. 9

Pointers.............................................................................................................................. 9

Display............................................................................................................................... 10

Vector-container............................................................................................................... 12

Punten waarbij de coordinaten uit pointers bestaan.................................................. 13

Pointer-bag........................................................................................................................ 14

De y-pos-container.......................................................................................................... 16

Een environment-laag...................................................................................................... 18

De verzameling lagen....................................................................................................... 24

Het object dat de grafische uitvoer regelt.................................................................... 28

Procedures & Environments........................................................................................................... 31

Primitives........................................................................................................................... 31

Nodige kleurtjes................................................................................................................ 32

Een Procedure-object....................................................................................................... 32

De environment-bindingen............................................................................................. 36

Het environment-object................................................................................................... 41

De garbage-collector........................................................................................................ 46

De evaluator...................................................................................................................................... 48

Self-evaluating, var & quote........................................................................................... 48

Define's & Lambda's........................................................................................................ 48

Set!...................................................................................................................................... 49

Apply-routines................................................................................................................. 49

Sequences......................................................................................................................... 50

Cond................................................................................................................................... 50

If.......................................................................................................................................... 51

Let....................................................................................................................................... 52

Begin.................................................................................................................................. 53

Evaluate & Apply............................................................................................................. 53

Load, Reset! & Driver-loop............................................................................................. 54

Trace-window & main-loop............................................................................................ 55

Begeleidend woordje

Om het lezen van de source iets aangenamer te maken bied ik U onderstaand tekstje aan.

In onderstaande source wordt het verschil tussen source en commentaar op volgende wijze duidelijk gemaakt :

Dit is source

En dit is commentaar

Ik geef altijd eerst de commentaar en nadien pas de implementatie.

Normaal wordt de source altijd onmiddelijk becommentariëerd, terwijl men ze aan het schrijven is. Ik heb dit gedaan maar ik heb ze nadien in deze tekstverwerker samengep(l)akt zodat ze gemakkelijker leest. De tekeningetjes die ik heb toegevoegd zijn er die ik op papier had staan om het voor mezelf duidelijk te houden.

Wat is volgens mij interresant, en wat minder ?

Grafische routines : een layer rond de BGI, weinig interresant

Grafische layout : Dit is het belangrijkste vind ik persoonlijk

Procedures & Environments : ook interresant maar deze zijn slechts aangepast zodat ze gelayouted kunnen worden.

De evaluator : hoofdzakelijk uit het boek van Abelson en Sussman.

Grafische routines

Onderstaande twee files heb ik nodig, de ene - graphics.fsl - om grafisch iets op het scherm te krijgen en de andere - peek.fsl - om de shift toets te kunnen uitlezen.

(load (%system-file-name "graphics.fsl"))

(load (%system-file-name "peek.fsl"))

Types

Ik zal eerst definieren wat een type is, dit is altijd handig en je hebt er minder debug-werk mee.

(define (attachtype typename content)

(cons typename content))

(define (type obj)

(if (procedure? obj)

(obj 'type)

(car obj)))

(define (contents obj)

(cdr obj))

Een aantal algemene routines

Hieronder staan een paar routines die een verbetering zijn van diegene die PCS levert, of die ik vaak gebruik.
De random van PCS is er zo eentje die de geest geeft als je hem oproept met waarde 0.

(define (my-random x)

(if (= x 0)

(random x)))

(define (sqr x)

(* x x))

(define (mid l r)

(/ (+ l r) 2))

(define (sign x)

(cond ((> x 0) 1)

((< x 0) -1)

(else 0)))

(macro not-eq? (lambda (e)

`(not (eq? ,(cadr e) ,(caddr e) ))))

(define JA (lambda () #t))

(define NEE (lambda () #f))

De volgende functie is er een die een lijst als invoer neemt en er de elementen die voldoen aan 'deze?' uithaalt. Ook het eerste element kan er zo afgehaald worden en daarom heb ik er de macro Delete-list-elementen aan toegevoegd.

(define (Delete-list-elementen-aux lst deze? DoeVoort?)
(define (delete-iter prev cur)
    (cond ((null? cur) #t)
          ((deze? (car cur))
           (set-cdr! prev (cdr cur))
           (if (DoeVoort?) (delete-iter prev (cdr cur))))
          (else (delete-iter cur (cdr cur)))))
(let* ((prefix (cons '() lst)))
    (delete-iter prefix lst)
    (cdr prefix)))

(macro delete-list-elementen

(lambda (parameters)

`(set!

,(cadr parameters)

(Delete-list-elementen-aux

,(cadr parameters)

,(caddr parameters)

,(cadddr parameters)))))

Punten

Dan beginnen hier de echte grafische routines, Punten bijvoorbeeld zijn altijd handig als je grafisch werkt.

(define (same-point? p1 p2)

(and (= (x p1) (x p2))

(= (y p1) (y p2))))

(define (maxx! p x)
(if (> x (car p)) (set-car! p x))
p)

(define (maxy! p y)
(if (> y (cdr p)) (set-cdr! p y))
p)

(define (setx! p x)
(set-car! p x)
p)

(define (sety! p y)
(set-cdr! p y)
p)

(define (addy! p dy)
(set-cdr! p (+ dy (cdr p)))
p)

(define (addx! p dx)
(set-car! p (+ dx (car p)))
p)

(define (copy-point p)
(cons (car p) (cdr p)))

(define (make-point x y)
(cons x y))

(define (x pos)
(car pos))

(define (y pos)
(cdr pos))

(define (add-point lt wh)
  (make-point
    (+ (x lt) (x wh))
    (+ (y lt) (y wh))))

(define (sub-point lt wh)

(make-point

(- (x lt) (x wh))

(- (y lt) (y wh))))

(define (distance p1 p2)

(sqrt (+ (sqr (- (x p1) (x p2)))

(sqr (- (y p1) (y p2))))))

Rectangles

Dan worden nu rectangles gedefinieerd. Deze worden enkel gebruikt als lijm voor punten, speciale operaties zoals intersect, left, right, top, bottom... zijn niet geïmplementeerd omdat ze niet nodig blijken.

(define (make-rect-xy lt rb)

(attachtype 'rectangle (cons lt rb)))

(define (make-rect-wh lt wh)

(make-rect-xy lt (add-point lt wh)))

(define (left-top rectangle)

(car (contents rectangle)))

(define (right-bottom rectangle)

(cdr (contents rectangle)))

(define (size rectangle)

(let ((rb (Right-Bottom rectangle))

(lt (left-top rectangle)))

(make-point (- (x rb) (x lt))

(- (y rb) (y lt)))))

Box

Dan wil ik nu ook de mogelijkheid om een gevuld blok in een bepaalde kleur op het scherm te krijgen. Rect moet gemaakt zijn met make-rect-xy of make-rect-wh.

(define (clearbox color rect)

(selectcolor color)

(bar (left-top rect) (Right-Bottom rect)))

En de onderstaande tekent een kader op het scherm in de gegeven kleur.

(define (drawbox color rect)
(clearbox color rect)
(let* ((lt (left-top rect))
         (rb (Right-Bottom rect))
         (rt (make-point (x rb) (y lt)))
         (lb (make-point (x lt) (y rb))))
    (line lt rt)
    (line rt rb)
    (line rb lb)
    (line lb lt)))

Text

Deze routine voert domweg de tekst uit naar het scherm, na de juiste kleur ingesteld te hebben.

(define (enkeltekst color left-top wat)

(set-color (foreground color))

(out-text-xy left-top wat))

Maar deze routine is iets verstandiger, ze verwijdert eerst de tekst die er reeds staat en tekent dan pas de tekst erover.

(define (textout color left-top wat . textlength)

(if textlength

(clearbox color (Make-Rect-wh left-top (make-point (* (car textlength) 8) 7)))

(clearbox color (Make-Rect-wh left-top (make-point (* (string-length wat) 8) 7))))

(out-text-xy left-top wat))

Views

Een viewport kan ook worden gemaakt.

(define (makeview color rect)

(attachtype 'view (cons rect color)))

(define (selectview view)

(if (eq? (type view) 'view)

(set-viewport

(left-top (viewrect view))

(Right-Bottom (viewrect view))

(error "Type mismatch, setview")))

(define (clearview view)

(selectview view)

(clearbox

(viewcolor view)

(Make-Rect-wh

(make-point 0 0)

(size (viewrect view)))))

(define (viewcolor view)

(cdr (contents view)))

(define (viewrect view)

(car (contents view)))

Colors

In dit project geef ik er de voorkeur aan dat de background en de foreground onafscheidelijk zijn, daarom wordt er een makecolor gedefiniëerd samen met twee selectoren.

(define (makecolor fg bg)

(attachtype 'color (cons fg bg)))

(define (foreground color)

(car (contents color)))

(define (background color)

(cdr (contents color)))

(define (selectcolor color)
(set-color (foreground color))
(set-fill-style 1 (background color)))

Cirkels

Ook cirkels moet ik kunnen tekenen : Een procedure wordt voorgesteld door twee cirkeltjes.

(define (cirkel color centrum r)

(SelectColor color)

(circle centrum r))

(define (disque color centrum r)

(set-fill-style 1 (background color))

(Set-color (background color))

(pie-slice centrum 0 360 r)

(Set-color (foreground color))

(circle centrum r))

Init & done

MaxCoor heb ik nodig om te beslissen hoe groot de view moet zijn waar de environments in komen. MaxColor is nodig om terug te schakelen naar monochrome schermpjes.

(define MaxCoor #f)

(define MaxColor #f)

Init-screen zoekt zelf achter de aanwezige hardware (De BGI komt bovendrijven). De aspect-ratio moet op 1-1 worden ingesteld omdat ik nergens in mijn berekeningen rekening houd met cirkels die eigenlijk als ovalen getekend moeten worden.

(define (init-screen)

(init-graph)

(set-aspect-ratio '(1 . 1))

(set! MaxCoor (Get-Max-xy))

(set! MaxColor (Get-Max-Color)))

(define (donescreen)

(close-graph))

Grafische Layout

Wat op het scherm komt heeft steeds de volgende structuur : De environments worden op het scherm gezet in lagen. De bovenste laag is de laag van environments & procedures met geen voorouders (enkel de Global Environment dus). Zo een laag wordt gemaakt met make-env-niveau. Het gemaakte object zorgt dan voor de verdeling van de environments & arrows over de laag die het voorstelt. Al de lagen worden bijgehouden in een aparte environment, envniveaus genaamd. Deze zorgt ervoor dat de arrows die door meerdere lagen kunnen gaan goed gerouted worden.

Om er voor te zorgen dat dit koppel objecten zomaar al de posities kan aanpassen zonder er de environments expliciet van op de hoogte te stellen houd ik pointers naar coordinaten bij. Belangrijk hierbij is dat deze pointers twee fields hebben,

Eén field voor de coordinaat, zowel de environments als de envniveaus mogen deze uitlezen

Eén field voor informatie enkel geschikt voor de envniveaus. Voor de x-posities zit hier in tot welke environment de x-positie behoort. Dit kan een Arrow, een Environment of een Procedure zijn. De info-fields van de y-coordinaten bevatten ofwel de Arrow tot wie ze behoren, ofwel de voorganger in de lijst van posities. (Dit zal duidelijker worden bij de Pointer-bag)

Al de coordinaten die hieronder staan zien er dus als volgt uit

Dit soort punten dient een naam te hebben en ik heb niets anders gevonden dan de foute naam 'pospointer'. Deze naam is fout omdat het geen pointer naar een positie is maar een positie met pointers in. Op een paar plaatsen heb ik ze dan maar wanhopig pointptrptr's genoemd (probeer dit zeker niet uit te spreken)

Pointers

Laat ik dan maar eerst beginnen met een pointer te definieren, Ik bouw ze gewoon op uit cons-cellen, ik kan er een type aanhangen maar ik doe dat niet omdat er anders een drastisch geheugentekort opduikt, samen met een dieptepunt voor de snelheid. Eerst een constructor...

(define (make-pointer content . info)
(cons content
    (if info
        (car info)
        info)))

(define (pointer-contents p)
(car p))

(define (pointer-info p)
(cdr p))

(define (set-pointer-info! p newinfo)
(set-cdr! p newinfo))

(define (set-pointer-contents! p newcontent)
(set-car! p newcontent))

Display

Deze routines zijn hulpprocedures die ik nadien gebruik om scheme-expressies uit te voeren. De redenen waarom ik ze herschreven heb :

Afhankelijk van de plaats waar procedures geprint worden, moeten ze anders geprint worden. Als ik naar het tekstschermpje iets uitvoer moet de procedure-naam opgezocht worden, maar als ik in de environment-tekeningetjes een procedure teken moet ik werkelijk een pijl tekenen naar die procedure.

Primitieve procedures hebben een niet-standaard PCS-achtige voorstelling, dus moet ik ook de primitieven onderscheppen.

De bedoeling was ook dat dit project circulaire lijsten zou aankunnen, en dan zou ik enkel deze routines moeten aanpassen.

Splitsstring is een routine die de gegeven 'tekst' splitst op de positie 'at'. Als de splitspositie lager gaat dan 'cutpos' dan kap ik de string gewoonweg in stukken. Het resultaat van deze functie is een lijst van strings waarin de 'tekst' gesplitstst is in zijn x delen.

(define (splitsstring at cutpos tekst)

(define (calcsplitspos afkappos string)

(define (iter pos)

(cond ((> (- afkappos pos) cutpos) afkappos)

((char=? (string-ref string pos) '#\SPACE) (+ pos 1))

(else (iter (- pos 1)))))

(iter afkappos))

(define (checksplitsing tekst)

(if (null? tekst) '()

(let* ((str (car tekst))

(strlen (string-length str)))

(if (> strlen at)

(let ((splitspos (calcsplitspos at str)))

(cons (substring str 0 splitspos)

(checksplitsing

(list (substring str splitspos strlen)))))

tekst))))

(checksplitsing (list tekst)))

Dan komt hier hetgeen ik in het begin van de paragraaf vermeld heb.
Print is een procedure die slechts 1 parameter vereist. Namelijk de tekst die neergepoot hoort te worden. ProcPrint is een routine die enkel wordt aangeroepen als er een procedure geprint moet worden (geen primitieven). Procprint verwacht slechts 1 parameter, het procedure-object. Val is hetgeen uiteindelijk afgedrukt moet worden.

(define (display-object print procprint val)
(define (list-object l)
    (define (loop l)
      (cond ((null? l) (print ")"))
            ((atom? l)
             (print " . ")
             (display-object print procprint l)
             (print ")"))
            (else
              (display-object print procprint (car l))
              (print (if (pair? (cdr l)) " " ""))
              (loop (cdr l)))))
    (print "(")
    (loop l))

(define (print-vector v)
    (define (loop pos last)
      (cond ((= pos last)
             (display-object print procprint (vector-ref v last))
             (print ")"))
            (else

             (display-object print procprint (vector-ref v pos))
             (print " ")
             (loop (1+ pos) last))))
    (print "#(")
    (loop 0 (-1+ (vector-length v))))
(cond ((number? val) (print (number->string val)))
        ((string? val)
         (print #\")
         (print val)
         (print #\"))
        ((pair? val) (list-object val))
        ((null? val) (print "()"))
        ((symbol? val) (print (symbol->string val)))
        ((vector? val) (print-vector val))
        ((compound-procedure? val) (procprint val))
        ((primitive-procedure? val)
         (print "#<PRIMITIVE")
         (print (val 'procname))
         (print ">"))
        (else (error "unknown type"))))

En dan nu een nuttig voorbeeld van het gebruik van bovenstaande procedure. Procedures worden nu geprint als spaties.

(define (display-in-string val)
(let ((result ""))
    (define (printstr x)
      (set! result (string-append result x)))
    (display-object
      printstr
      (lambda (proc) (printstr " "))
      val)
    result))

Dit is dan de routine die werkelijk tekst zet in het tekstschermpje waar de gebruiker geconsulteerd wordt. Procedures worden nu werkelijk geprint met hun echte naam.

(define (my-display val)
(display-object
    (lambda (text)
      (display text trace-window))
    (lambda (proc)
      (display "#<PROCEDURE" trace-window)

(display (proc 'procname) trace-window)

(display ">" trace-window))

val))

Vector-container

Dit ADT heb ik geschreven omdat het sneller gaat dan lijsten, minder geheugen vraagt en toch nog dynamisch blijft. Dit idee is gebaseerd op de TCollection van Borland C++ & Turbo Pascal 6.0. Het maakt een container waarin de hoofdstructuur bestaat uit vectoren (De naam is alweer slecht gekozen, een vectorcontainer is eigelijk een container waarin vectoren bewaard worden, maar ik vond hem al lang genoeg)

Size is de maat waarmee de container uitbreid telkens als hij vol zit. Ter verduidelijking een MS-Drawtje

(define (make-vectorcontainer size)
(let ((lastelement -1)
(HeadVector (make-vector (1+ size))))

    (define (Vector&Nr pos)
      (define (GetInVect pos vct)
        (if (>= pos size)
            (begin
              (if (null? (vector-ref vct size))
                  (vector-set! vct size (make-vector (1+ size))))
              (GetInVect (- pos size) (vector-ref vct size)))
            (cons vct pos)))
      (if (> pos lastelement) (set! lastelement pos))
      (GetInVect pos HeadVector))

    (define (Element-At pos)
      (let ((V&N (Vector&Nr pos)))
        (vector-ref (car V&N) (cdr V&N))))

    (define (Set-Element-At pos to)
      (let ((V&N (Vector&Nr pos)))
        (vector-set! (car V&N) (cdr V&N) to)))

    (define (At pos)
      (if (or (< pos 0) (> pos lastelement))
          #f
          (Element-At pos)))

    (define (Set-At! pos el)
      (if (< pos 0)
          (error "verkeerde positie, VECTORCONTAINER")
          (Set-Element-At pos el)))

    (define (getlastelement)
      (if (= lastelement -1) #f
          (Element-At lastelement)))

    (define (foreach-until action)
      (define (Iter aantaltotnutoe pos vct)
        (cond ((> aantaltotnutoe lastelement) #f)
              ((= pos size)
               (Iter aantaltotnutoe 0 (vector-ref vct size)))
              ((action (vector-ref vct pos)) (vector-ref vct pos))
              (else (Iter (1+ aantaltotnutoe) (1+ pos) vct))))
      (Iter 0 0 HeadVector))

    (define (vectorcontainer mesg)
      (cond ((eq? mesg 'at) at)
            ((eq? mesg 'set-at!) set-at!)
            ((eq? mesg 'last-element-nr?) lastelement)
            ((eq? mesg 'last-element?) (getlastelement))
            ((eq? mesg 'foreach-until) foreach-until)
            (else (error "Unkown Message, VECTORCONTAINER" mesg))))
    vectorcontainer))

Punten waarbij de coordinaten uit pointers bestaan

(define (make-pointptrptr x1 env x2)
(make-point (make-pointer x1 env)
(make-pointer x2)))

(define (deepx pointptrptr)
(pointer-contents (x pointptrptr)))

(define (deepy pointptrptr)
(pointer-contents (y pointptrptr)))

(define (set-deepx! pointptrptr wat)
(set-pointer-contents! (x pointptrptr) wat))

(define (set-deepy! pointptrptr wat)
(set-pointer-contents! (y pointptrptr) wat))

(define (normalize p)
(make-point (deepx p) (deepy p)))

Pointer-bag

Dit is een verzameling van pointers. De content van elke pointer behoort tot een environment en daar blijft dit object dus mooi af, maar de info van elke pointer is van mij. Dit wil zeggen dat ik een Bag kan maken waarbij het inserten en deleten beiden gebeuren in een constante tijd O(1). Even tonen hoe deze bag er in het algemeen uitziet.

Als ik nu de pointer krijg met het element 120 in, dan kan ik deze onmiddelijk verwijderen omdat ik zijn voorganger ken, zijn opvolger en het aantal keer dat hij bekend is. O(1)
Het inserten doe ik steeds aan de postfix vanachter, dus ook O(1)

Laat ik weer eens beginnen met de selectoren te definieren

(define (bag-data el)
(pointer-info el))

(define (counter-field el)
(vector-ref el 2))

(define (prev-pointer el)
(vector-ref el 0))

(define (next-pointer el)
(vector-ref el 1))

(define (set-counter-field! el wat)
(vector-set! el 2 wat))

(define (set-prev-pointer! el wat)
(vector-set! el 0 wat))

(define (set-next-pointer! el wat)
(vector-set! el 1 wat))

(define (make-bag-data prev next count)
(vector prev next count))

(define (bag-data? d)
(vector? d))

(define (make-pointerbag)
(let ((prefix-data #f)
(postfix #f)
(postfix-data #f))

    (define (insert el)
      (let ((el-data (bag-data el)))
        (if (bag-data? el-data)
            (set-counter-field! el-data (1+ (counter-field el-data)))
            (let ((voorlaatste (prev-pointer postfix-data)))
              (set-pointer-info! el
                (make-bag-data voorlaatste postfix 1))
              (set-next-pointer! (bag-data voorlaatste) el)
              (set-prev-pointer! postfix-data el)))
        el))

    (define (Foreach action)
      (define (iter cur)
        (if (eq? cur postfix)
            #t
            (begin
              (action cur)
              (iter (next-pointer (bag-data cur))))))
      (iter (next-pointer prefix-data)))

    (define (pointerbag mesg)
      (cond ((eq? mesg 'Insert) Insert)
            ((eq? mesg 'Foreach) Foreach)
            (else (error "Unkown Message POINTER-BAG" mesg))))

    (let ((prefix #f))
      (set! postfix-data (make-bag-data #f #f 'postfix-counter))
      (set! postfix (make-pointer 'postfix postfix-data))
      (set! prefix-data (make-bag-data #f postfix 'prefix-counter))
      (set! prefix (make-pointer 'prefix prefix-data))
      (set-prev-pointer! postfix-data prefix))
    pointerbag))

Dit is raar omdat dit eigelijk een operatie is die hoort in bovenstaande structuur. Ik heb hem eruit gehaald omdat ik zo de bag niet moet opzoeken waarin de pointer zit, maar direct impliciet weet welke bag ik beet heb en het element eruit keil.

(define (delete-el-uit-bag el)

(let* ((el-data (bag-data el))

(el-counter (counter-field el-data)))

(if (= el-counter 1)

(let* ((prev (prev-pointer el-data))

(next (next-pointer el-data))

(prev-data (bag-data prev))

(next-data (bag-data next)))

(set-next-pointer! prev-data next)

(set-prev-pointer! next-data prev)

(set-next-pointer! el-data #f)

(set-prev-pointer! el-data #f))

(set-counter-field! el-data (-1+ (counter-field el-data))))

#t))

De y-pos-container

Deze container bevat al de y-posities die gereserveerd zijn door arrows.

Bespreking van de messages

(GetPos arrow): Zoekt een vrije y-positie waar de arrow door kan. Geef een coordinaatpointer weer als resultaat.

(Remove-Possen arrow) : Verwijdert al de y-coordinaten gereserveerd voor 'arrow'.

(Set-Upperpos! ny) : Verandert de top vanwaar de y-posities beginnen.

(Move-down! dy) : Verplaatst de top dy pixels naar beneden.

(Aantal) : Geeft het aantal aanwezige gebruikte y-posities weer

De parameter 'delta' die wordt meegegeven aan (make-arrow-poscontainer ...) is de afstand die er minimum moet zijn tussen twee arrows. (Deze zal later ingesteld worden op 5)

(define (make-arrow-poscontainer UpperPos Delta)

(let ((SortedPossen '())

(aantal 0))

(define (GetPos arrow)

(define result #f)

(define (looplist prev lastpos lst)

(define (AppendIfPosbl PosToAppend AppendCons NextCons)

(set! result (make-pointer PosToAppend arrow))

(set-cdr! AppendCons (cons result NextCons)))

(cond ((null? lst)

(AppendIfPosbl (+ lastpos delta) prev '()))

((>= (- (pointer-contents (car lst)) lastpos)

(* 2 delta))

(AppendIfPosbl (+ lastpos delta) prev lst))

(else

(looplist

lst

(pointer-contents (car lst))

(cdr lst)))))

(let ((prefix

(cons (make-pointer (- UpperPos Delta)) SortedPossen)))

(looplist prefix (- UpperPos Delta) SortedPossen)

(set! SortedPossen (cdr prefix)))

(set! aantal (1+ aantal))

result)

(define (Remove-Possen arrow)

(delete-list-elementen SortedPossen

(lambda (ptr) (eq? (pointer-info ptr) arrow))

(lambda () (set! aantal (-1+ aantal)))))

    (define (set-upperpos! newpos)
      (cond ((= upperpos newpos) #t)
            ((< newpos upperpos)
             (set! upperpos newpos))
            (else
             (let ((verschil (- newpos upperpos)))
               (for-each
                 (lambda (e)
                   (set-pointer-contents! e (+ (car e) verschil)))
                 SortedPossen)
               (set! upperpos newpos)))))

    (define (move-down! hoeveel)
      (set-upperpos! (+ hoeveel upperpos)))

    (define (poscontainer mesg)
      (cond ((eq? mesg 'GetPos) GetPos)
            ((eq? mesg 'Remove-Possen) Remove-Possen)
            ((eq? mesg 'set-upperpos!) set-upperpos!)
            ((eq? mesg 'move-down!) move-down!)
            ((eq? mesg 'aantal) aantal)
            (else (error "Unkown message ARROWPOSCONTAINER" mesg))))
    poscontainer))

Een environment-laag

Voor ik een laag ga definieren leg ik uit uit welke deelstukken een environment-laag of environment-niveau bestaat.

De x-posities van punten die in environments liggen bestaan uit coordinaatpointers. De contents van zo één pointer is de x-coordinaat. De info is de bijhorende environment.

De x-posities van arrows die buiten de environments liggen bestaan eveneens uit pospointers. De contents is weerom de x-coordinaat en de info is nu het bijhorende Arrow-object.

De y-posities die in environments liggen worden gezamelijk bijgehouden in een pointer-bag.

De y-posities die onder de environments liggen worden verzamelt in de eerder gemaakte arrow-poscontainer.

Messages :

(insert env LT RB) : voegt een nieuwe environment toe.

(recalc-sizes) : herrekent de hoogte van de laag. De x-posities van environments worden verschoven indien nodig.

(recalc-arrows) : Verplaatst de arrows naar beneden indien de hoogte van de environment-laag is gewijzigd.

bottom : geeft de onderste lijn (y-positie) van de laag weer

top : geeft de bovenste lijn (y-positie) van de laag weer.

diepte : geeft het niveau weer van de laag

(set-top! ny) verplaatst de toplijn van de laag naar boven of beneden. Alle coordinaten van de environments & arrows worden vanzelf mee aangepast.

(move-down! dy) verplaatst de laag dy naar beneden. (zie set-top!)

(delete env) : verwijdert de gegeven environment

(foreach-env action) : roept action op voor elke aanwezige environment.

(GetNewXPos arrow indebuurtvan) : zoekt een x-positie waar een arrow vertikaal door kan zonder een environment te snijden. 'InDeBuurtVan' is een parameter die zegt waar ongeveer deze positie gewenst is.

(GetNewYPos arrow) : zoekt een vrije y-positie onder de environments voor de gegeven arrow.

(remove-arrow arrow) : verwijdert alle x&y-posities die in verband staan met deze arrow.

(record-pos ptrtopos) : onthoud de x-coordinaat van deze positie in Xpossen. De y-coordinaat wordt in de PosBag gegooid.

(unrecord-pos ptrtopos) : verwijdert al de coordinaten van het gegeven punt.

(define verschiltussenniveaus 50)
(define delta-between-envs 21)

(define (make-envniveau diepte)
(let ((xpossen '())
        (top 0)
        (bottom 0)
        (envbottom 0)
        (yposseninenvs (make-pointerbag))
        (arrowypossen (make-arrow-poscontainer 0 5)))

    (define (insert env LT RB)
      (if RB
          (let* ((nlt (normalize LT))
                 (nrb (normalize RB))
                 (size (sub-point nRB nlt))
                 (to-add #f))
            (search-x-pos-env env LT)
            (set! to-add (sub-point (normalize LT) nLT))
            (set-deepx! RB (+ (x nrb) (x to-add)))
           (set-deepy! RB (+ (y nrb) (y to-add)))
            ((yposseninenvs 'insert) (y LT))
            (record-pos RB))
          (begin
            (search-x-pos-env env LT)
            ((yposseninenvs 'insert) (y LT)))))

(define (envptr? ptr envval arrowval)
(if (eq? ((pointer-info ptr) 'type) 'arrow) arrowval envval))

    (define (search-x-pos-env newenv result)
      (define sizeenv (x (newenv 'size)))
      (define (insert-after cell pos)
        (set-deepx! result pos)
        (set-deepy! result top)
        (set-cdr! cell (cons (x result) (cdr cell))))
      (define (search-x-iter curxpos prev cur)
        (if (null? cur)
            (insert-after prev curxpos)
            (let* ((ptr (car cur))
                   (ptrinf (pointer-info ptr)))
              (if (and
                    (car prev)
                    (eq? (pointer-info (car prev)) ptrinf))
                  (search-x-iter curxpos cur (cdr cur))
                  (if (eq? (ptrinf 'type) 'arrow)
                      (let ((arrowx (pointer-contents ptr)))
                        (if (< arrowx (+ curxpos sizeenv 5))
                            (search-x-iter
                              (max (+ arrowx 5) curxpos)
                              cur
                              (cdr cur))
                            (insert-after prev curxpos)))
                      (let ((envleft (ptrinf 'left)))
                        (if (< envleft
                              (+ curxpos sizeenv delta-between-envs))
                            (search-x-iter
                              (max
                                (+ envleft (x (ptrinf 'size))
                                   delta-between-envs)
                                curxpos)
                              cur (cdr cur))
                            (insert-after prev curxpos))))))))
      (let* ((prefix (cons #f xpossen))
             (result (search-x-iter 0 prefix xpossen)))
        (set! xpossen (cdr prefix))
        result))

(define (recalc-arrows)

((arrowypossen 'set-upperpos!) (+ envbottom 10)))

(define (recalc-sizes)

(define (loop lst maxhoogte left-for-envs left-for-arrows

move-right old-env)

(if (null? lst) maxhoogte

(if (envptr? (car lst) #t #f)

(let ((env (pointer-info (car lst))))

(if (eq? env old-env)

(let ((curpos (+ (pointer-contents (car lst))

move-right)))

(if (> curpos (env 'right))

(set! curpos (env 'right)))

(set-pointer-contents! (car lst) curpos)

(loop (cdr lst)

maxhoogte

left-for-envs

left-for-arrows

move-right

env))

                        (begin
                          (set! move-right 0)
                          (if (< (env 'left)
                                 (max left-for-envs left-for-arrows))
                              (begin
                                (set! move-right
                                  (- (max left-for-envs
                                          left-for-arrows)
                                     (env 'left)))
                                (set-pointer-contents! (car lst)
                                  (+ (pointer-contents (car lst))
                                     move-right))
                                (env 'activatepos)))
                          (loop (cdr lst)
                                (max maxhoogte (y (env 'size?)))
                                (+ (env 'right) delta-between-envs)
                                (+ (env 'right) 5)
                                move-right
                                env))))

(begin

(if (< (pointer-contents (car lst))

left-for-arrows)

(set-pointer-contents! (car lst)

left-for-arrows))

(loop (cdr lst)

maxhoogte

left-for-envs

(+ (pointer-contents (car lst)) 5)

old-env)))))

(let ((maxhoogte (loop xpossen 0 0 0 0 #f)))

(set! envbottom (+ top maxhoogte))

(set! bottom

(+ (* (arrowypossen 'aantal) 5) top maxhoogte 20))))

(define (set-top! newtop)

(set! bottom (+ bottom (- newtop top)))

(set! envbottom (+ envbottom (- newtop top)))

(set! top newtop))

    (define (move-down! hoeveel)
      (set-top! (+ top hoeveel))
      ((arrowypossen 'move-down!) hoeveel)
      ((yposseninenvs 'foreach)
        (lambda (pointptrptr)

(set-pointer-contents! pointptrptr

(+ (pointer-contents pointptrptr) hoeveel))))

(foreach-env (lambda (env) (env 'ActivatePos))))

(define (delete env)

(delete-list-elementen xpossen

(lambda (ptr) (eq? (pointer-info ptr) env))

NEE))

    (define (foreach-env action)
      (let ((lastenv #f))
        (define (loop lst)
          (if (null? lst) #t
              (if (eq? (pointer-info (car lst)) lastenv)
                  (loop (cdr lst))
                  (begin
                    (set! lastenv (pointer-info (car lst)))
                    (if (envptr? (car lst) #t #f) (action lastenv))
                    (loop (cdr lst))))))
        (loop xpossen)))

(define (GetNewXPos InDeBuurtVan Arrow)

(define result #f)

(define (breedte-ptr ptr)

(if (eq? ((pointer-info ptr) 'type) 'arrow)

(+ (x ((pointer-info ptr) 'size)) 5)))

(define (insert-after cell pos)

(set! result (make-pointer pos arrow))

(set-cdr! cell (cons result (cdr cell))))

(define (search-x-iter curxpos prev cur)

(cond ((null? cur)

(insert-after prev curxpos))

((and

(car prev)

(eq? (pointer-info (car prev))

(pointer-info (car cur))))

(search-x-iter curxpos cur (cdr cur)))

(else

(let* ((ptr (car cur))

(x-left (- (pointer-contents ptr) 5))

(x-right (+ 5 x-left (breedte-ptr ptr))))

(if (< curxpos x-left)

(insert-after prev curxpos)

(search-x-iter

(max x-right curxpos)

cur (cdr cur)))))))

(let ((prefix (cons #f xpossen)))

(search-x-iter 20 prefix xpossen)

(set! xpossen (cdr prefix)))

result)

(define (GetNewYPos arrow)

((arrowypossen 'GetPos) arrow))

(define (Remove-Arrow arrow)

(remove-y-possen arrow)

(remove-x-possen arrow))

(define (Remove-Y-Possen arrow)
((arrowypossen 'remove-possen) arrow))

(define (Remove-X-possen arrow)

(delete-list-elementen xpossen

(lambda (ptr) (eq? (pointer-info ptr) arrow))

JA))

    (define (record-pos ptrtopos)
      (define (loop env lst)
        (cond ((null? lst) (error "Recpos : " diepte ptrtopos))
              ((eq? (pointer-info (car lst)) env)
               (set-cdr! lst (cons (x ptrtopos) (cdr lst))))
              (else (loop env (cdr lst)))))
      (loop (pointer-info (x ptrtopos)) xpossen)
      ((yposseninenvs 'insert) (y ptrtopos))
      ptrtopos)

(define (Unrecord-pos ptrtopos)

(delete-list-elementen xpossen

(lambda (ptr) (eq? ptr (x ptrtopos)))

NEE)

(delete-el-uit-bag (y ptrtopos))

ptrtopos)

(define (envniveau mesg)

(cond ((eq? mesg 'insert) insert)

((eq? mesg 'recalc-sizes) (recalc-sizes))

((eq? mesg 'recalc-arrows) (recalc-arrows))

((eq? mesg 'bottom) bottom)

((eq? mesg 'top) top)

((eq? mesg 'diepte) diepte)

((eq? mesg 'set-top!) set-top!)

((eq? mesg 'delete) delete)

((eq? mesg 'foreach-env) foreach-env)

((eq? mesg 'GetNewXPos) GetNewXPos)

((eq? mesg 'GetNewYPos) GetNewYPos)

((eq? mesg 'Remove-Arrow) Remove-Arrow)

((eq? mesg 'Move-Down!) Move-Down!)

((eq? mesg 'Record-Pos) Record-Pos)

((eq? mesg 'Unrecord-Pos) Unrecord-Pos)

(else (error "unkown request envniveau" mesg))))

envniveau))

De verzameling lagen

Envniveaus is geen echt object omdat het slechts éénmalig in geheugen zit. Ik had dit kunnen implementeren door gebruik te maken van make-environment maar de leesbaarheid van de code daalt daar zo erg mee dat ik het niet heb gedaan.

Messages :

(insert env LT RB) : zoekt de passende laag op voor env en insert env erin.

(delete env) : zoekt de passende laag op en delete er env

(check-niveau-sizes) : checkt voor elk, niveau zijn totale grootte en verschuift de andere lagen indien nodig naar beneden.

(check-arrows) : roept voor alle lagen 'check-arrows op

(foreach-env action) : past op elke environment aanwezig in al de lagen action toe.

(make-arrow from to) : Maakt een arrow-object.dat bij de creatie zelf zijn weg zoekt tussen de environments.

(record-pos pospointer) : zoekt de juiste laag op en roept daar 'record-pos aan.

(unrecord-pos pospointer) : zoekt de juiste laag op en roept 'unrecord-pos op.

(reset!) : verwijdert al de aanwezige lagen.

Deze omgeving maakt ook de arrowobjecten. Mogelijke messages aan het adres van de arrows zijn :

type : geeft 'Arrow weer

(redraw color) : hertekent de arrow (zonder te herrekenen) in de gegeven kleur color.

(JeBentTeVeel) : OK, de arrow weet dat hij te veel is en zal zichzelf uit de environment-lagen verwijderen.

from : geeft het from-point weer

to : geeft het to-point weer

(define envniveaus

(let ((niveaus (make-vectorcontainer 6)))

(define (reset!)

(set! niveaus (make-vectorcontainer 6)))

(define (niveau-at pos)

((niveaus 'at) pos))

(define (addniveau niveau)

((niveaus 'set-at!) (niveau 'diepte) niveau))

(define (maxniveau)

(niveaus 'last-element-nr?))

(define (volgendniveau niv)

((niveaus 'at) (1+ (niv 'diepte))))

(define (VorigNiveau niv)

((niveaus 'at) (- (niv 'diepte) 1)))

(define (LastNiveau)

(niveaus 'Last-Element?))

(define (foreach-niveau-until action)

((niveaus 'foreach-until) action))

(define (NextNiveauHoogte)

(let ((last (LastNiveau)))

(if last (+ (last 'bottom) verschiltussenniveaus) 0)))

    (define (insert env LT RB)
      (let* ((niveau-diepte (env 'diepte))
             (verschil (- niveau-diepte (maxniveau))))
        (cond ((= verschil 1)
               (let ((newniveau (make-envniveau niveau-diepte)))
                 ((newniveau 'set-top!) (nextniveauhoogte))
                 ((newniveau 'insert) env LT RB)
                 (addniveau newniveau)))
              ((> verschil 1) (error "Niveau overgeslagen..."))
              (else
                (((niveau-at niveau-diepte) 'insert) env LT RB)))))

(define (delete env)

(((niveau-at (env 'diepte)) 'delete) env))

(define (foreach-env action)

(foreach-niveau-until

(lambda (n)

((n 'foreach-env) action)

#f)))

(define (check-niveau-sizes)

(define mxnivnr (maxniveau))

(define (push-down wat hoeveel)

(define (actie hier)

(if (> hier mxnivnr) #t

(begin

(((niveau-at hier) 'move-down!) hoeveel)

(actie (1+ hier)))))

(actie wat))

(define (top->bot nivnr)

(let ((niv (niveau-at nivnr)))

(niv 'recalc-sizes)

(if (= nivnr mxnivnr) #t

(let* ((calced-top-next-niv (niv 'bottom))

(real-top-next-niv

((niveau-at (1+ nivnr)) 'top)))

(if (> calced-top-next-niv real-top-next-niv)

(Push-Down

(1+ nivnr)

(- calced-top-next-niv real-top-next-niv)))

(top->bot (1+ nivnr))))))

(top->bot 0))

    (define (make-arrow From To)
      (let ((puntenlijst '()))
        (define (from-env)
          (pointer-info (x from)))
        (define (to-env)
          (pointer-info (x to)))
        (define (from-env-depth)
          ((from-env) 'diepte))
        (define (to-env-depth)
          ((to-env) 'diepte))

        (define (CalcPath)
          (let* ((FromNiveau (niveau-at (from-env-depth)))
                 (ToNiveau (niveau-at (to-env-depth))))
            (define (ConsPoint p)
              (set! puntenlijst (cons p puntenlijst)))
            (define (UpToVerbinding CurrentPoint CurrentNiveau)
              (if (eq? Currentniveau ToNiveau)
                  (ConsPoint (make-point (x To) (y CurrentPoint)))
                  (let* ((SecondPoint
                           (make-point
                             ((CurrentNiveau 'GetNewXPos)
                               To ArrowObject)
                             (y CurrentPoint)))
                         (PrevNiveau (VorigNiveau CurrentNiveau))

(ThirdPoint

(make-point

(x SecondPoint)

((PrevNiveau 'GetNewYPos) arrowobject))))

(ConsPoint SecondPoint)

(ConsPoint ThirdPoint)

(UpToVerbinding ThirdPoint PrevNiveau))))

(define (DownToVerbinding CurrentPoint CurrentNiveau)

(let ((NextNiveau (VolgendNiveau CurrentNiveau)))

(if (eq? NextNiveau ToNiveau)

(ConsPoint (Make-point (x To) (y CurrentPoint)))

(let* ((SecondPoint

(Make-point

((NextNiveau 'GetNewXPos)

To ArrowObject)

(y CurrentPoint)))

(ThirdPoint

(Make-Point

(x SecondPoint)

((NextNiveau 'GetNewYPos)

arrowobject))))

(ConsPoint SecondPoint)

(ConsPoint ThirdPoint)

(DownToVerbinding ThirdPoint NextNiveau)))))

(cond ((eq? FromNiveau ToNiveau)

(let ((NewFrom

(make-point (x From)

((FromNiveau 'GetNewYPos) arrowobject))))

(ConsPoint From)

(ConsPoint NewFrom)

(UpToVerbinding NewFrom FromNiveau)))

((> (y (Normalize From)) (y (Normalize To)))

(let* ((PrevNiv (VorigNiveau FromNiveau))

(NewFrom

(make-point (x From)

((PrevNiv 'GetNewYPos) arrowobject))))

(ConsPoint From)

(ConsPoint NewFrom)

(UpToVerbinding NewFrom PrevNiv)))

(else

(let ((NewFrom

(make-point (x From)

((FromNiveau 'GetNewYPos) arrowobject))))

(ConsPoint From)

(ConsPoint NewFrom)

(DownToVerbinding NewFrom FromNiveau))))))

        (define (redraw color)
          ((diagrammen 'DrawLLine)
             color (map (lambda (p) (normalize p)) puntenlijst))
          ((Diagrammen 'DrawFromToArrow)
             color (normalize (car puntenlijst)) (normalize To)))

(define (ikbenteveel)

(let ((fromdepth (from-env-depth))

(todepth (to-env-depth)))

(define (loop start stop)

(if (> start stop)

(begin

(((niveau-at start) 'remove-arrow) arrowobject)

(loop (1+ start) stop))))

(loop (min fromdepth todepth) (max fromdepth todepth))

(unrecord-pos From fromdepth)

(unrecord-pos To todepth)))

(define (arrowobject mesg)

(cond ((eq? mesg 'type) 'arrow)

((eq? mesg 'redraw) redraw)

((eq? mesg 'JeBentTeVeel) (IkBenTeVeel))

((eq? mesg 'from) from)

((eq? mesg 'to) to)

(else (error "Unkown request, ARROW" mesg))))

(CalcPath)

arrowobject))

(define (check-arrows)

(foreach-niveau-until (lambda (niv) (niv 'recalc-arrows) #f)))

(define (record-pos envdiepte ptrpos)

(((niveau-at envdiepte) 'record-pos) ptrpos))

(define (unrecord-pos ptrpos diepte)

(((niveau-at diepte) 'unrecord-pos) ptrpos))

(define (dispatch mesg)

(cond ((eq? mesg 'insert) insert)

((eq? mesg 'delete) delete)

((eq? mesg 'check-niveau-sizes) (check-niveau-sizes))

((eq? mesg 'check-arrows) (check-arrows))

((eq? mesg 'foreach-env) foreach-env)

((eq? mesg 'make-arrow) make-arrow)

((eq? mesg 'record-pos) record-pos)

((eq? mesg 'unrecord-pos) unrecord-pos)

((eq? mesg 'reset!) (reset!))

(else (error "unkown request niveaus" mesg))))

dispatch))

Het object dat de grafische uitvoer regelt

Omdat ik wil dat alle tekeningen die gemaakt worden op het scherm relatief zijn t.o.v een bepaalde 'LeftTop' is deze omgeving aanwezig. Het maakt een view juist boven de trace-window (dit is het tekstvenster onderaan het scherm). Al de coordinaten die worden meegegeven aan functies van deze omgeving worden verandert door er LeftTop af te trekken. De LeftTop kan verplaatst worden met de berichten Move-Right, Move-Left, Move-Up, Move-Down & Home.

Messages i.v.m. environments

(HereIam env LT RB) : Geeft het bericht 'insert env LT RB' aan envniveaus, herrekent dan de groottes en hertekent uiteindelijk de diagrammen op het scherm.

(CheckAll) : controleert of er geen environments overlappen en of alle pijlen goed liggen.

(Destructive-call) : de evaluator heeft iets destructiefs gedaan en dan moet eens gecontroleerd worden of alle environments nog intact zijn.

Messages om te tekenen

(Box color rect) : tekent gewoon een gevuld rechthoekje op het scherm

(Text color tekst pos) : tekent in kleur 'color' op positie 'pos' de gegeven tekst 'tekst' nadat de benodige plaats is leeg gemaakt.

(transparanteText color tekst pos) : tekent in kleur 'color' op positie 'pos' de gegeven tekst 'tekst' ZONDER de benodige plaats eerst te clearen.

(disque color centrum straal) : tekent een schijf

(DrawLLine color lst) : tekent een L-lijn tussen de gegeven punten. De Punten moeten in een lineaire lijst 'lst' zitten.

(DrawFromToArrow color from to) : tekent een arrow met een pijltje (zin-driehoekje) aan.

(totaly-redraw) : hertekent al de environments

Messages om de LeftTop te verplaatsen

(move-up veel?) : verplaats LeftTop naar boven. Als Veel? false is dan wordt er maar maxy/10 naar boven geschoven, in het andere geval wordt er maxy/2 naar boven geschoven.

(move-down veel?) : ± idem

(move-right veel?) : ± idem

(move-left veel?) : ± idem

(home) : verplaatst LeftTop naar (0 . 0)

(reset!) : initialiseert de view die nodig is om de diagrammen in te tekenen.

(define diagrammen

(let ((diagramscreen #f)

(lefttop (make-point 0 0)))

(define (HereIam env LT RB)

(garbage-collector 'inc-env-counter)

((envniveaus 'insert) env LT RB))

(define (CheckAll)

(envniveaus 'check-niveau-sizes)

(envniveaus 'check-arrows)

(totaly-redraw))

(define (totaly-redraw)

(clearview diagramscreen)

((envniveaus 'foreach-env) (lambda (p) (p 'redraw))))

    (define (Box Color Rect)
      (drawbox color
        (make-rect-xy
          (sub-point (left-top rect) lefttop)
          (sub-point (right-bottom rect) lefttop))))

(define (Text Color tekst pos)

(textout color (sub-point pos lefttop) tekst))

(define (TransparanteText Color tekst pos)

(EnkelTekst Color (sub-point pos lefttop) tekst))

(define (DoDisque Color Centrum Straal)

(Cirkel Color (sub-point Centrum lefttop) Straal))

(define (DrawFromToArrow Color From To)

(define (CalcPuntWithAngle hoek)

(make-point (- (x To) (* (cos hoek) 10))

(+ (y To) (* (sin hoek) 10))))

(define (GetHoek)

(let* ((straal (distance From To))

(cosofhoek (/ (- (x To) (x From)) straal))

(Hoek-I-II (acos cosofhoek)))

(if (> (y To) (y From))

(- (* 2 PI) Hoek-I-II)

Hoek-I-II)))

(let* ((hoek (GetHoek))

(hoek1 (+ hoek (/ (* 15 PI) 180))) ;15 graden

(hoek2 (- hoek (/ (* 15 PI) 180)))

(punt1 (sub-point (CalcPuntWithAngle hoek1) lefttop))

(punt2 (sub-point (CalcPuntWithAngle hoek2) lefttop))

(to2 (sub-point to lefttop)))

(selectcolor Color)

(line (sub-point from lefttop) to2)

(line to2 punt1)

(line to2 punt2)))

(define (DrawLLine color lst)

(define (DrawLLineWerkelijk l)

(cond ((null? l) #t)

((null? (cdr l)) #t)

(else

(Line

(sub-point (car l) lefttop)

(sub-point (cadr l) lefttop))

(DrawLLineWerkelijk (cdr l)))))

(selectcolor Color)

(DrawLLineWerkelijk lst))

(define (reset!)

(set! diagramscreen

(makeview

(makecolor 0 0)

(make-rect-xy

(make-point 0 0)

(make-point (x maxcoor) (-1+ trace-window-top))))))

(define (destructive-call)

((envniveaus 'foreach-env)

(lambda (e) (e 're-initialiseer-bindingen)))

((envniveaus 'foreach-env)

(lambda (e) (e 're-activate-arrows)))

(checkall))

    (define (move-right veel?)
      (addx! LeftTop (if veel? (/ (x maxcoor) 2) (/ (x maxcoor) 10)))
      (totaly-redraw))

    (define (home)
      (set! LeftTop (make-point 0 0))
      (totaly-redraw))

(define (move-left veel?)

(addx! LeftTop

(if veel? (/ (x maxcoor) -2) (/ (x maxcoor) -10)))

(totaly-redraw))

(define (move-up veel?)

(addy! LeftTop

(if veel? (/ (y maxcoor) -2) (/ (y maxcoor) -10)))

(totaly-redraw))

(define (move-down veel?)

(addy! LeftTop

(if veel? (/ (y maxcoor) 2) (/ (y maxcoor) 10)))

(totaly-redraw))

(define (shell mesg)

(cond ((eq? mesg 'HereIam) HereIam)

((eq? mesg 'CheckAll) (CheckAll))

((eq? mesg 'Box) Box)

((eq? mesg 'Text) Text)

((eq? mesg 'TransparanteText) TransparanteText)

((eq? mesg 'Disque) DoDisque)

((eq? mesg 'DrawLLine) DrawLLine)

((eq? mesg 'DrawFromToArrow) DrawFromToArrow)

((eq? mesg 'destructive-call) (destructive-call))

((eq? mesg 'move-up) move-up)

((eq? mesg 'move-down) move-down)

((eq? mesg 'move-left) move-left)

((eq? mesg 'move-right) move-right)

((eq? mesg 'home) (home))

((eq? mesg 'reset!) (reset!))

((eq? mesg 'totaly-redraw) (totaly-redraw))

(else (error "Unknown request, DIAGRAMMEN" mesg))))

shell))

Procedures & Environments

Nu is al gedefiniëerd hoe procedures en environments op scherm komen en gaan. Nu moet ik ervoor zorgen dat deze twee ook meespelen. Ze moeten bijvoorbeeld zeggen wanneer ze een destructieve call plegen, wanneer ze verandert zijn van grootte...

Maar eerst definieer ik Primitives.

Primitives

(define primitives

'(-1+ 1+ + - * / and or not set-car! set-cdr! car cdr cons eq?
    equal? = <= >= < > abs even? null? exit load freesp
    collect-garbage set-garbage-grens! vector? vector->list
    make-vector vector vector-length vector-ref vector-set!))

(define destructives '(set-car! set-cdr! vector-set!))

(define (create-primitive name)

(define (getprocname)

(string-append " " (symbol->string name)))

(define (load-file filename trace-into)

(let ((port (if (file-exists? filename)

(open-input-file filename)

#f)))

(if port

(load-loop port trace-into)

#f)))

(define (action args insprong trace-into)

(if (eq? name 'LOAD)

(load-file (car args) trace-into)

(let ((result (apply (eval name) args)))

(if (member name destructives)

(diagrammen 'destructive-call))

result)))

(define (primitive mesg)

(cond ((eq? mesg 'apply) action)

((eq? mesg 'type) 'primitive)

((eq? mesg 'procname) (getprocname))

(else (error "unkown request, PRIMITIVE" mesg))))

primitive)

(define (primitive-procedure? p)

(and (procedure? p) (eq? (p 'type) 'primitive)))

(define (get-primitive name)

(if (member name primitives)

(create-primitive name)

#f))

Nodige kleurtjes

(define active-proc-text-color (makecolor 2 0))
(define active-proc-arrow-color (makecolor 2 0))
(define search-binding-color (makecolor 14 2))
(define active-env-text-color (makecolor 14 1))
(define active-env-arrow-color (makecolor 15 1))
(define dead-env-text-color (makecolor 7 8))
(define dead-env-arrow-color (makecolor 7 0))

(define (Shit-Mono!)

(let ((zwart-op-wit (makecolor 0 1))

(wit-op-zwart (makecolor 1 0)))

(set! active-proc-text-color wit-op-zwart)

(set! active-proc-arrow-color wit-op-zwart)

(set! search-binding-color zwart-op-wit)

(set! active-env-text-color wit-op-zwart)

(set! active-env-arrow-color wit-op-zwart)

(set! dead-env-text-color wit-op-zwart)

(set! dead-env-arrow-color wit-op-zwart)))

Een Procedure-object

Messages i.v.m. de evaluator

Environment : geeft de environment weer waarbinnen de procedure gedefinieerd is.

ProcName : geeft de naam weer die de procedure heeft, als ze geen naam heeft krijg je "" weer.

SetProcName : verandert de naam van de procedure

ForgetProcName : verwijdert de naam van de procedure

Apply : past de functie toe op de gegeven parameters.

Grafische Messages

Type : geeft 'Procedure weer

Diepte : geeft weer hoeveel voorouders er zijn

Size & Size? : geven beide de grootte weer van het blokje dat bezet wordt door de procedure.

Set-top! : verplaatst de top van de procedure.

Left : geeft de linker-coordinaat weer van de procedure

Right : geeft de rechter-coordinaat weer van de procedure

Top : geeft de top-coordinaat weer van de procedure

Redraw : hertekent de procedure door gebruik te maken van de omgeving 'diagrammen'

WijsNaarPunt : geeft een pospointer weer naar het middelpunt van de linkercirkel.

Messages i.v.m. de garbage-collector

SetNotConnected : Zegt aan de procedure dat hij niet aan de evaluatie noch aan de global environment gebonden is. (ook niet indirect)

Connection-test : De procedure weet nu dat hij geconnecteerd is. Hij geeft dit bericht door aan de vader-omgeving. (Hier zie je werkelijk die message-passing)

Check-connection : De procedure controleert of ze niet te veel is, indien wel verwijdert ze zichzelf.

(define (create-procedure lambda-exp env)
(let ((LT #f)
        (WH (make-point 40 20))
        (procname #f)
        (connected #f)
        (PijlNaarVader #f))

    (define (left)
      (deepx LT))

(define (right)
(+ (left) (x WH)))

(define (top)

(deepy LT))

(define (bottom)

(+ (top) (y WH)))

(define (wijsnaarpunt-pos)

(make-point (- (right) 30) (+ (top) 10)))

(define (wijsnaarpunt)

((envniveaus 'record-pos)

(diepte)

(make-pointptrptr (- (right) 30) procedure (+ (top) 10))))

(define (aanhechtingfrom-pos)

(if PijlNaarVader

(normalize (pijlnaarvader 'from))

(error "Error call-volgorde PROCEDURE")))

(define (gesplitsteparametertekst)

(splitsstring 20 15 (display-in-string (parameters))))

(define (parameterbodysize)

(let ((tekstlist (gesplitsteparametertekst))

(maxpoint (make-point 40 12)))

(define (iter lst)

(if (null? lst)

maxpoint

(let ((lenx (+ 4 (* 8 (string-length (car lst))))))

(maxx! maxpoint lenx)

(addy! maxpoint 8)

(iter (cdr lst)))))

(iter tekstlist)))

    (define (redraw)
      (let ((disque2 (aanhechtingfrom-pos))
            (disque1 (wijsnaarpunt-pos)))
        (define (drawparameters)
          (let ((ypos (+ (top) 2))
                (xgrens (- (right) 42)))
            (define (iter lst)
              (if (null? lst) #t
                  (let* ((tekst (car lst))
                         (xpos
                           (- xgrens (* (string-length tekst) 8))))
                    ((diagrammen 'transparantetext)
                      active-proc-text-color tekst
                      (make-point xpos ypos))
                    (set! ypos (+ ypos 8))
                    (iter (cdr lst)))))
            (iter (gesplitsteparametertekst))))
        ((diagrammen 'disque) active-proc-text-color disque1 10)
        ((diagrammen 'disque) active-proc-text-color disque1 1)
        ((diagrammen 'disque) active-proc-text-color disque2 10)
        ((diagrammen 'disque) active-proc-text-color disque2 1)
        (drawparameters)
        ((diagrammen 'transparantetext)
          active-proc-text-color "Body"
          (make-point (- (x disque1) 48) (- (bottom) 10)))
        ((PijlNaarVader 'Redraw) active-proc-arrow-color)))

(define (recalc-size)

(let ((tempsize (parameterbodysize)))

(addx! WH (x tempsize))

(maxy! WH (y tempsize))))

(define (parameters)

(cadr lambda-exp))

(define (body)

(cddr lambda-exp))

(define (diepte)

(1+ (env 'diepte)))

(define (set-top! ny)

(set-deepy! LT ny))

(define (action arguments insprong trace-into)

(eval-sequence

(body)

((create-environment

(parameters)

arguments

env) 'inceval)

insprong

trace-into))

(define (setnotconnected)

(set! connected #f))

(define (connection-test)

(if connected #t

(begin

(set! connected #t)

(env 'connection-test))))

(define (setprocname newname)
(if (not procname) (set! procname newname)))

(define (forgetprocname)

(set! procname #f))

(define (getprocname)

(if (not procname)

(string-append " " (symbol->string procname))))

(define (make-pijlnaarvader)

(let* ((depth (diepte))

(from ((envniveaus 'record-pos) depth

(make-pointptrptr

(- (right) 10) procedure (+ (top) 10))))

(to ((env 'mogelijkeaansluiting) procedure

(normalize from))))

(set! PijlNaarVader ((envniveaus 'make-arrow) from to))))

(define (checkconnection)

(if (not connected)

(begin

((envniveaus 'delete) procedure)

(PijlNaarVader 'JeBentTeVeel))))

    (define (procedure mesg)
      (cond ((eq? mesg 'environment) env)
            ((eq? mesg 'apply) action)
            ((eq? mesg 'diepte) (diepte))

((eq? mesg 'type) 'procedure)

((eq? mesg 'size) WH)

((eq? mesg 'size?) WH)

((eq? mesg 'activatepos) #t)

((eq? mesg 'set-top!) set-top!)

((eq? mesg 'left) (left))

((eq? mesg 'top) (top))

((eq? mesg 'procname) (getprocname))

((eq? mesg 'setprocname) setprocname)

((eq? mesg 'forgetprocname) (forgetprocname))

((eq? mesg 'redraw) (redraw))

((eq? mesg 'right) (right))

((eq? mesg 'evaluating?) #f)

((eq? mesg 'wijsnaarpunt) (wijsnaarpunt))

((eq? mesg 'setnotconnected) (setnotconnected))

((eq? mesg 'connection-test) (connection-test))

((eq? mesg 'checkconnection) (checkconnection))

((eq? mesg 're-initialiseer-bindingen) #t)

((eq? mesg 're-activate-arrows) #t)

(else (error "unkown request, PROCEDURE" mesg))))

(set! LT (make-pointptrptr 0 procedure 0))

(recalc-size)

((diagrammen 'HereIam) procedure LT #f)

(Make-PijlnaarVader)

(redraw)

procedure))

(define (foreach-procin exp action)

(cond ((compound-procedure? exp) (action exp))

((pair? exp)

(foreach-procin (car exp) action)

(foreach-procin (cdr exp) action))))

(define (compound-procedure? proc)

(and (procedure? proc) (eq? (proc 'type) 'procedure)))

De environment-bindingen

Dit is de binding-container. Hij bevat al de bindingen die horen bij een bepaalde environment. Deze zorgt ook dat de arrows op de juiste plaatsen vertrekken...

Messages zijn : Insert (een binding), Foreach, Search (zoek een binding op), Size?, JeBentTeVeel, ReDraw, Initialiseer (herrekent de posities van de bindingen)

(define (create-binding-container left-top)
(let ((bindingen '())
(last '()))

(define (foreach-binding action)
(for-each action bindingen))

    (define (insert b)
      (if last
          (begin
            (set-cdr! last (cons b '()))
            (set! last (cdr last)))
          (set! last (set! bindingen (cons b '())))))

(define (find-binding var lst)

(cond ((null? lst) #f)

((eq? ((car lst) 'var) var)

((car lst) 'flash))

(else (find-binding var (cdr lst)))))

(define (search var)

(find-binding var bindingen))

(define (splits wat)

(define (splitsm procend normalend rest)

(cond ((null? rest) #t)

(((car rest) 'procedure-binding?)

(splitsm

(cdr (set-cdr! procend (cons (car rest) '())))

normalend (cdr rest)))

(else

(splitsm procend

(cdr (set-cdr! normalend (cons (car rest) '())))

(cdr rest)))))

(let ((n (cons '() '()))

(p (cons '() '())))

(splitsm p n wat)

(cons (cdr n) (cdr p))))

    (define (size?)
      (let ((maxlenx 0)
            (proclenx -10)
            (splitslist (splits bindingen))
            (leny 0))
        (define (NewProcBinding Binding)
          (set! proclenx (+ (+ (x (binding 'size?)) 10) proclenx)))
        (define (NewNormalBinding Binding)
          (let ((size (binding 'size?)))
            (if (> (x size) maxlenx) (set! maxlenx (x size)))
            (set! leny (+ leny (y size)))))
        (for-each NewNormalBinding (car splitslist))
        (for-each NewProcBinding (cdr splitslist))
        (if (not (null? (cdr splitslist))) (set! leny (+ leny 16)))
        (make-point (max maxlenx proclenx) leny)))

(define (initialiseer)
(let ((proclenx -10)

(splitslist (splits bindingen))

(leny 0))

(define (NewProcBinding Binding)

(let ((xs (+ (x (binding 'size?)) 10))

(newpos

(add-point left-top

(make-point (+ proclenx 10) leny))))

((binding 'set-pos!) newpos)

(set! proclenx (+ xs proclenx))))

(define (NewNormalBinding Binding)
(let ((size (binding 'size?)))

((binding 'set-pos!)

(add-point left-top (make-point 0 leny)))

(set! leny (+ leny (y size)))))

(for-each NewNormalBinding (car splitslist))

(for-each NewProcBinding (cdr splitslist))))

(define (redraw tekstkleur pijlkleur)

(foreach-binding (lambda (b)

((b 'redraw-text) tekstkleur)))

(foreach-binding (lambda (b)

((b 'redraw-arrows) pijlkleur))))

(define (set-voorlopige-pos! p)

(set! left-top p)

(initialiseer))

(define (activate-arrows diepte env)

(foreach-binding

(lambda (b) ((b 'activate-arrows) diepte env))))

(define (ikbenteveel)

(foreach-binding (lambda (b) (b 'jebentteveel))))

(define (binding-container mesg)

(cond ((eq? mesg 'insert) insert)

((eq? mesg 'foreach) foreach-binding)

((eq? mesg 'search) search)

((eq? mesg 'size?) (size?))

((eq? mesg 'initialiseer) (initialiseer))

((eq? mesg 'jebentteveel) (ikbenteveel))

((eq? mesg 'activate-arrows) activate-arrows)

((eq? mesg 'redraw) redraw)

((eq? mesg 'set-voorlopige-pos!) set-voorlopige-pos!)

(else (error "unkown request, BINDING-CONTAINER" mesg))))

binding-container))

Messages die gestuurd kunnen worden naar een binding :

Var : geeft de variable weer

Val : geeft de bijhorende value weer

Set-Value! : de set! operator

Procedure-binding : geeft true weer als het een variabele is die direct gebonden is aan een procedure (dus niet langs lijsten om)

Type : 'binding

Redraw-text : hertekent enkel de tekst

Redraw-arrows : hertekent enkel de pijlen

Activate-arrows : herrekent al de pijlen

JeBentTeVeel : verwijdert deze binding en zijn bijhorende arrows

Flash : tekent de binding in het groen op het scherm

(define (create-binding var val global?)
(let ((pos (make-point 0 0))

(arrows '()))

(define (set-pos! npos)

(set! pos npos))

(define (set-binding-value! nval)

(if (compound-procedure? val) (val 'forgetprocname))

(set! val nval)

(delallarrows)

(if (compound-procedure? val) ((val 'setprocname) var)))

    (define (delallarrows)
      (for-each (lambda (a) (a 'jebentteveel)) arrows)
      (set! arrows '()))

(define (bindings-tekst)

;de bindings-tekst --> VARIABLE : VALUE

;bij een procedure --> VARIABLE

(if (procedure-binding?)

(symbol->string var)

(string-append (symbol->string var)

" : "

(display-in-string val))))

(define (size?)

(let ((tekst (draw-text))

(result (make-point 0 0)))

(define (iter tekst)

(if (null? tekst) result

(begin

(maxx! result (* 8 (string-length (car tekst))))

(addy! result 8)

(iter (cdr tekst)))))

(iter tekst)))

(define (procedure-binding?)

(compound-procedure? val))

(define (draw-text)

(if (and (not global?) (not (procedure-binding?)))

(gesplitste-bindings-tekst)

(list (bindings-tekst))))

(define (gesplitste-bindings-tekst)
(splitsstring 30 10 (bindings-tekst)))

(define (redraw-text textcolor)

(let ((temp (copy-point pos)))

(define (draw lst)

(cond ((null? lst) #t)

(else

((diagrammen 'text) textcolor (car lst) temp)

(addy! temp 8)

(draw (cdr lst)))))

(draw (draw-text))))

    (define (activate-arrows diepte env)
      (let ((abspos (copy-point pos))
            (cutlst (map string-length (draw-text)))
            (curcol 0)
            (LastProcessed '()))
        (define (add-arrow from to)
          (set! Arrows
            (cons

((envniveaus 'make-arrow)

((envniveaus 'record-pos) diepte from)

to)

Arrows)))

(define (addcurcol l)

(set! curcol (+ l curcol))

(addx! abspos (* 8 l))

(if (and (not (null? cutlst)) (>= curcol (car cutlst)))

(begin

(set! curcol (- curcol (car cutlst)))

(set! cutlst (cdr cutlst))

(addy! abspos 8)

(setx! abspos (x pos))

(addcurcol 0))))

(define (screen-out tekst)

(addcurcol (string-length tekst)))

(define (printproc p)

(add-arrow

(make-pointptrptr (+ 4 (x Abspos)) env (+ 4 (y AbsPos)))

(p 'wijsnaarpunt))

(addcurcol 1))

(DelAllArrows)

(if (procedure-binding?)

(add-arrow

(make-pointptrptr

(+ (x AbsPos)

(* 4 (string-length (Symbol->string var)))) env

(+ (y AbsPos) 12))

(val 'wijsnaarpunt))

(begin

(addcurcol (+ (string-length (Symbol->string var)) 3))

(display-object screen-out printproc val)))))

(define (redraw-arrows arrowcolor)

(for-each

(lambda (arrow)

((arrow 'redraw) arrowcolor))

arrows))

(define (flash)

(redraw-text search-binding-color)

binding)

    (define (binding mesg)
      (cond ((eq? mesg 'redraw-text) redraw-text)
            ((eq? mesg 'redraw-arrows) redraw-arrows)
            ((eq? mesg 'activate-arrows) activate-arrows)
            ((eq? mesg 'set-value!) set-binding-value!)
            ((eq? mesg 'value) val)
            ((eq? mesg 'var) var)
            ((eq? mesg 'bindings-tekst) (bindings-tekst))
            ((eq? mesg 'gesplitste-bindings-tekst)
             (gesplitste-bindings-tekst))
            ((eq? mesg 'size?) (size?))
            ((eq? mesg 'type) 'binding)
            ((eq? mesg 'set-pos!) set-pos!)
            ((eq? mesg 'procedure-binding?) (procedure-binding?))
            ((eq? mesg 'jebentteveel) (delallarrows))
            ((eq? mesg 'flash) (flash))
            (else (error "unknown request, BINDING" mesg))))

(if (compound-procedure? val) ((val 'setprocname) var))

binding))

(define (is-binding? binding)

(and (procedure? binding) (eq? (binding 'type) 'binding)))

Het environment-object

Het environment-object bestaat een een binding-container die het grootste werk van de grafische uitvoer op zich neemt. Het enige dat environment nu nog moet doen is zijn coordinaten in orde houden en antwoorden op vragen van de evaluator

Messages van de evaluator :

Type : 'environment

Binding-in : zoekt achter een bepaalde binding met als sleutel de variable.

Lookup-variable-value : zoekt achter de value van een bepaalde variable.

Set-Variable-value! : verandert de waarde van een bepaalde variable

Define-variable! : de Define in actie.

IncEval : Zegt aan de environment dat er een actie in hem plaats grijpt en dat hij nodig is.

DecEval : Zegt aan de environment dat de actie afgelopen is en dat hij kan barsten.

Grafische berichten

Redraw : hertekent de environment op de gekende positie en hertekent dan de bindingen.

Size : vraagt de size gewoonweg op, zonder ze te herrekenen

Size? : vraagt de size op, maar herrekent de groottes van de bindingen eerst.

Left : geeftt de linker-coordinaat weer

Right : geeft de rechter-coordinaat weer

Bottom : geeft de ondergrens weer

Top : geeft de bovengrens weer

Set-Top! : verandert de bovengrens, en verplaatst de ondergens naar onder.

Diepte : geeft weer hoeveel voorouders er zijn

ActivatePos : Zegt aan de environment dat zijn positie gewijzigt is.

Re-activate-arrows : is synoniem voor 'Herreken je arrows'

Activate-arrows : Teken je pijltjes

Re-initialiseer-bindingen : Er kan iets verandert zijn na een set! operatie, dus mag je al je bindingen eens herrekenen.

MogelijkeAansluiting : geeft weer waar een pijl zich aan de onderkant van de environment mag plaatsen.

Messages van de garbage-collector

Connection-test : zet zijn eigen connection-flag op #t , zegt aan vader dat hij ook verbonden is en dan worden al de bindingen afgegaan op zoek achter procedures.

CheckConnection : controleert of deze environment nog wel nodig is, indien niet verwijdert ze zichzelf.

SetNotConnected : De environment zet z'n connected-flag op #f.

Evaluating? : controleert of er in de gegeven environment nog steeds wordt geëvalueert.

(define (create-environment . extended)
(let ((LT #f)
        (RB #f)
        (Bindingen (create-binding-container (make-point 2 2)))
        (EvalFlag 0)
        (Grootstex 0)
        (Connected #f)
      (VerbindingNaarVader #f)
        (Parent-Environment '()))

(define (size)
(sub-point (normalize RB) (normalize LT)))

(define (top)
(deepy LT))

(define (bottom)

(deepy RB))

(define (left)

(deepx LT))

(define (right)

(deepx RB))

(define (aanhechtingfrom)

((envniveaus 'record-pos)

(diepte)

(make-pointptrptr

(mid (left) (right)) environment

(top))))

(define (aanhechtingfrom-pos)

(if VerbindingNaarVader

(normalize (Verbindingnaarvader 'from))

(error "Error in call-volgorde")))

(define (evaluating?)

(> evalflag 0))

(define (active-color?)

(evaluating?))

(define (getenvcolor)

(if (active-color?)

active-env-text-color

dead-env-text-color))

(define (getarrowcolor)

(if (active-color?)

active-env-arrow-color

dead-env-arrow-color))

(define (getprocarrowcolor)

active-proc-arrow-color)

(define (global?)

(null? parent-environment))

(define (size?)

(set-size!

(if (global?)

(let ((bindingensize (bindingen 'size?)))

(make-point

(max

grootstex

(+ (x bindingensize) 4)) (+ (y bindingensize) 4)))

(add-point (bindingen 'size?) (make-point 4 4)))))

(define (pos-changed)

((bindingen 'set-voorlopige-pos!) (bindingpos)))

(define (bindingpos)

(add-point (normalize LT) (make-point 2 2)))

    (define (redraw)
      (let ((envcolor (getenvcolor))
            (arrowcolor (getarrowcolor)))
        ((diagrammen 'box) envcolor

(make-rect-xy (normalize LT) (normalize RB)))

((bindingen 'redraw) envcolor arrowcolor)

(if VerbindingNaarVader

((VerbindingNaarVader 'ReDraw) arrowcolor))))

(define (set-size! newsize)

(set-deepx! RB (+ (left) (x newsize)))

(set-deepy! RB (+ (top) (y newsize)))

newsize)

(define (foreach-proc proc)

(define (checkproc binding)

(foreach-procin (binding 'value) proc))

((bindingen 'foreach) checkproc))

(define (binding-in-here var)

((bindingen 'search) var))

(define (binding-in var)

(if (global?)

(let ((result (binding-in-here var)))

(if result

result

(let ((temp (get-primitive var)))

(if temp

(create-binding var temp #t)

#f))))

(or (binding-in-here var)

((parent-environment 'binding-in) var))))

(define (insert-bindings variables values)

(cond ((and (null? variables) (null? values)) '())

((null? variables)

(error "Too many values supplied"))

((null? values)

(error "Too few values supplied"))

(else

((bindingen 'insert)

(create-binding

(car variables)

(car values)

(global?)))

(insert-bindings (cdr variables) (cdr values)))))

(define (lookup-variable var)

(let ((binding (binding-in var)))

(if (is-binding? binding)

(binding 'value)

(error "Unbound variable" var))))

(define (set-variable-value! var val)

(let ((binding (binding-in var)))

(if (is-binding? binding)

(begin

((binding 'set-value!) val)

(diagrammen 'destructive-call))

(error "Unbound variable" var))))

    (define (define-variable! var val)
      (let ((binding (binding-in-here var)))
        (if (is-binding? binding)
            (begin
              ((binding 'set-value!) val)
              (bindingen 'initialiseer)
              ((bindingen 'activate-arrows) (diepte) environment))
            (begin
              ((bindingen 'insert)

(create-binding var val (global?)))

(bindingen 'initialiseer)

((bindingen 'activate-arrows) (diepte) environment)))

(diagrammen 'checkall)))

(define (set-top! ny)

(sety! LT ny))

(define (mogelijkeaansluiting e p)

(if (global?)

(begin

(if (> (x p) grootstex)

(begin

(set! grootstex (x p))

(set-deepx! RB (x p))

(redraw)))

((envniveaus 'record-pos)

(diepte)

(make-point

(make-pointer (x p) environment)

(y RB))))

(let ((l (left))

(r (right))

(m (x p)))

((envniveaus 'record-pos)

(diepte)

(make-point

(make-pointer

(if (< m l) l

(if (> m r) r m))

environment)

(y RB))))))

(define (diepte)

(if (global?)

(1+ (parent-environment 'diepte))))

(define (inceval)

(set! evalflag (1+ evalflag))

(if (= evalflag 1) (redraw))

environment)

(define (deceval)

(set! evalflag (- evalflag 1))

(if (= evalflag 0) (redraw))

environment)

(define (setnotconnected)

(set! connected #f))

    (define (connection-test)
      (if connected
          #t
          (begin
            (set! connected #t)
            (foreach-proc (lambda (p) (p 'connection-test)))
            (if (not (global?))
                (parent-environment 'connection-test)))))

(define (checkconnection)

(if (not (or connected (evaluating?)))

(begin

((envniveaus 'delete) environment)

(bindingen 'jebentteveel)

((envniveaus 'unrecord-pos) RB (diepte))

(if Verbindingnaarvader

(VerbindingNaarVader 'jebentteveel)))))

(define (make-verbindingnaarvader)

(if (not (global?))

(let* ((F (AanhechtingFrom))

(T ((parent-environment 'mogelijkeaansluiting)

environment (normalize F))))

(set! VerbindingNaarVader

((envniveaus 'make-arrow) F T)))))

(define (environment mesg)

(cond ((eq? mesg 'type) 'environment)

((eq? mesg 'binding-in) binding-in)

((eq? mesg 'lookup-variable-value) lookup-variable)

((eq? mesg 'set-variable-value!) set-variable-value!)

((eq? mesg 'define-variable!) define-variable!)

((eq? mesg 'redraw) (redraw))

((eq? mesg 'size) (size))

((eq? mesg 'left) (left))

((eq? mesg 'right) (right))

((eq? mesg 'bottom) (bottom))

((eq? mesg 'top) (top))

((eq? mesg 'set-top!) set-top!)

((eq? mesg 'connection-test) (connection-test))

((eq? mesg 'diepte) (diepte))

((eq? mesg 'inceval) (inceval))

((eq? mesg 'deceval) (deceval))

((eq? mesg 'evaluating?) (evaluating?))

((eq? mesg 'setnotconnected) (setnotconnected))

((eq? mesg 'checkconnection) (checkconnection))

((eq? mesg 'ActivatePos) (Pos-Changed))

((eq? mesg 're-activate-arrows)

((bindingen 'activate-arrows) (diepte) environment))

((eq? mesg 're-initialiseer-bindingen)

(bindingen 'initialiseer))

((eq? mesg 'size?) (size?))

((eq? mesg 'mogelijkeaansluiting) mogelijkeaansluiting)

(else (error "unknown request : environment" mesg))))

    (set! LT (make-pointptrptr 0 environment 0))
    (set! RB (make-pointptrptr 4 environment 4))
    (if extended
      (begin
        (set! parent-environment (caddr extended))
        ((diagrammen 'hereIam) environment LT RB)
        (pos-changed)
        (insert-bindings (car extended) (cadr extended))
        (set! extended #f)
        (bindingen 'initialiseer)
        (size?)

((bindingen 'activate-arrows) (diepte) environment)

(make-verbindingnaarvader)

(diagrammen 'checkall))

(begin

((diagrammen 'hereIam) environment LT RB)

(Pos-Changed)

(make-verbindingnaarvader)

(diagrammen 'checkall)))

environment))

De garbage-collector

(define garbage-collector

(let ((sleepresultaat (list #f))

(aantalenvstoegevoegd 0)

(garbage-grens 10))

(define (removehead aantal)

(define (Iter pos l)

(if (= pos 0) l (Iter (- pos 1) (cdr l))))

(set! SleepResultaat (iter aantal SleepResultaat)))

(define (set-top! to)

(set-car! SleepResultaat to))

(define (pushem wat)

(set-car! SleepResultaat wat)

(set! SleepResultaat (cons #f SleepResultaat))

wat)

(define (reset!)

(set! SleepResultaat (list #f))

(set! aantalenvstoegevoegd 0))

(define (CollectGarbage)

(set! aantalenvstoegevoegd 0)

((envniveaus 'foreach-env) (lambda (e) (e 'setnotconnected)))

(foreach-procin SleepResultaat

(lambda (p) (p 'connection-test)))

(global-environment 'connection-test)

((envniveaus 'foreach-env) (lambda (e)

(if (e 'evaluating?)

(e 'connection-test))))

((envniveaus 'foreach-env) (lambda (e) (e 'checkconnection)))

(diagrammen 'totaly-redraw))

(define (inc-env-counter)

(set! aantalenvstoegevoegd (1+ aantalenvstoegevoegd))

(if (>= aantalenvstoegevoegd garbage-grens) (CollectGarbage)))

(define (set-garbage-grens! x)
(set! garbage-grens x))

    (define (sleep mesg)
      (cond ((eq? mesg 'reset!) (reset!))
            ((eq? mesg 'remove-sleeps-head) removehead)

((eq? mesg 'set-sleeps-top!) set-top!)

((eq? mesg 'push-sleeps) pushem)

((eq? mesg 'collectgarbage) (CollectGarbage))

((eq? mesg 'inc-env-counter) (inc-env-counter))

((eq? mesg 'set-garbage-grens!) set-garbage-grens!)

(else (error "Unkown request GARBAGE COLLECTOR" mesg))))

sleep))

(define (set-garbage-grens! x)

(if (< x 3)

"Garbage-grens >= 3 graag..."

((garbage-collector 'set-garbage-grens!) x)))

(define (collect-garbage)

(Garbage-Collector 'collectgarbage)

#t)

De evaluator

De evaluator ontdekt staartrecursie. Om dat te verwezelijken heb ik aan de environments een eval-count toegevoegd. Deze telt hoeveel expressies er geëvalueert worden in die bepaalde environment. De garbage-collector houdt rekening met dit vlagje. Dus het enige dat ik nog moet doen is OP TIJD de evalflag 1 verminderen. Het resultaat na elke evaluate moet een eval-verandering van 0 zijn in de gegeven environment

Het tracen gebeurt als volgt : Elke evaluate neemt 5 parameters :

exp : de expressie die te evalueren is

env : in de gegeven environment

insprong : waar de tekst moet komen op het schermpje onderaan

text : een begeleidend tekstje van wat er geëvalueert wordt

trace-into : staat op #t indien er ingetraced werd. Dit wil zeggen dat de gebruiker nog steeds iets te zeggen heeft. Trace-into staat op #f als er een step-over gepleegd werd.

Self-evaluating, var & quote

(define (self-evaluating? exp)

(or (string? exp)

(number? exp)

(boolean? exp)))

(define (quoted? exp)

(and (not (atom? exp)) (eq? (car exp) 'quote)))

(define (text-of-quotation exp)

(cadr exp))

(define (variable? exp)

(symbol? exp))

Define's & Lambda's

(define (definition? exp)
(and (not (atom? exp)) (eq? (car exp) 'define)))

(define (definition-variable exp)
(if (variable? (cadr exp))
(cadr exp)
(caadr exp)))

(define (definition-value exp)

(if (variable? (cadr exp))

(caddr exp)

(cons 'lambda

(cons (cdadr exp)

(cddr exp)))))

(define (eval-definition exp env insprong trace-into)
((env 'define-variable!) (definition-variable exp)
   (evaluate
     (definition-value exp)
     env
     insprong
     "Evalueer define-value "
     trace-into))
(env 'deceval)
(definition-variable exp))

(define (lambda? exp)

(and (not (atom? exp)) (eq? (car exp) 'lambda)))

Set!

(define (assignment? exp)

(and (not (atom? exp)) (eq? (car exp) 'set!)))

(define (assignment-variable exp)

(cadr exp))

(define (assignment-value exp)

(caddr exp))

(define (eval-assignment exp env insprong trace-into)

(let ((new-value (evaluate

(assignment-value exp)

env

insprong

"Evalueer set!'s parameters "

trace-into)))

((env 'set-variable-value!) (assignment-variable exp) new-value)

(env 'deceval)

new-value))

Apply-routines

(define (application? exp)
(pair? exp))

(define (operator app)

(car app))

(define (operands app)

(cdr app))

(define (first-operand args)

(car args))

(define (no-operands? args)

(null? args))

(define (rest-operands args)

(cdr args))

(define (list-of-values exps env insprong trace-into)
(cond ((no-operands? exps) '())
        (else
          (cons
            ((garbage-collector 'push-sleeps)
             (evaluate

(first-operand exps)

env

insprong

"Evalueer parameter "

trace-into))

(list-of-values

(rest-operands exps)

env

insprong

trace-into)))))

Sequences

(define (first-exp seq)

(car seq))

(define (last-exp? seq)

(null? (cdr seq)))

(define (rest-exps seq)

(cdr seq))

(define (eval-sequence exps env insprong trace-into)
(cond ((last-exp? exps)
         (evaluate
           (first-exp exps)
           (env 'deceval)
           insprong
           "Evalueer laatste opdracht "
           trace-into))
        (else
          (evaluate
            (first-exp exps)
            env
            insprong
            "Evalueer opdracht "
            trace-into)
          (eval-sequence (rest-exps exps) env insprong trace-into))))

Cond

(define (clauses exp)

(cdr exp))

(define (no-clauses? clauses)

(null? clauses))

(define (first-clause clauses)

(car clauses))

(define (rest-clauses clauses)

(cdr clauses))

(define (predicate clause)
(car clause))

(define (actions clause)

(cdr clause))

(define (else-clause? clause)

(eq? (predicate clause) 'else))

(define (eval-cond clist env insprong trace-into)

(cond ((no-clauses? clist)

(env 'deceval)

'())

((else-clause? (first-clause clist))

(eval-sequence

(actions (first-clause clist)) env insprong trace-into))

((true? (evaluate

(predicate (first-clause clist))

env

insprong

"Evalueer predicate "

trace-into))

(eval-sequence

(actions (first-clause clist)) env insprong trace-into))

(else

(eval-cond (rest-clauses clist) env insprong trace-into))))

(define (true? x)

(not (null? x)))

(define (conditional? exp)

(and (not (atom? exp)) (eq? (car exp) 'cond)))

If

(define (if? exp)

(and (not (atom? exp)) (eq? (car exp) 'if)))

(define (if-predicate exp)

(cadr exp))

(define (trueexp exp)

(caddr exp))

(define (falseexp exp)

(cadddr exp))

(define (exists-falseexp? exp)

(pair? (cdddr exp)))

(define (eval-if exp env insprong trace-into)
(if (true? (evaluate
               (if-predicate exp)
               env
               insprong
               "Evalueer if-conditie "
               trace-into))
      (evaluate
        (trueexp exp)
        (env 'deceval)
        insprong
        "Evalueer true-clause "
        trace-into)
      (begin
        (env 'deceval)
        (if (exists-falseexp? exp)
          (evaluate
            (falseexp exp)
            env

insprong

"Evalueer false-clause "

trace-into)

#f))))

Let

(define (let? exp)
(and (not (atom? exp)) (eq? (car exp) 'let)))

(define (let-body exp)
(cddr exp))

(define (let-va?list carcdr? exp)
(define (iter doubles result)
    (if (null? doubles)
        result
        (iter (cdr doubles) (cons (carcdr? (car doubles)) result))))

(iter (cadr exp) '()))

(define (let-varlist exp)

(let-va?list (lambda (lst) (car lst)) exp))

(define (let-vallist exp)

(let-va?list (lambda (lst) (cadr lst)) exp))

(define (eval-let exp env insprong trace-into)

(let* ((value-list (reverse (let-vallist exp)))

(variable-list (reverse (let-varlist exp)))

(result

(eval-sequence

(let-body exp)

((create-environment

variable-list

(list-of-values value-list env insprong trace-into)

env) 'inceval)

insprong

trace-into)))

((garbage-collector 'remove-sleeps-head) (length value-list))

(env 'deceval)

result))

Begin

(define (begin? exp)

(and (pair? exp) (eq? (car exp) 'begin)))

(define (eval-begin exp env insprong trace-into)

(eval-sequence (cdr exp) env insprong trace-into))

Evaluate & Apply

De eval-veranderingen in de meegegeven environment zijn als volgt :

evaluate 0

eval-define -1

eval-assignment -1

create-proc 0

eval-cond -1

eval-if -1

eval-sequence -1

eval-begin -1

(define (evaluate exp env insprong text trace-into)
((garbage-collector 'set-sleeps-top!) #f)
(env 'inceval)
(let* (
    (trace-next-into
      (if trace-into
        (begin
          (set-x-position insprong)
          (display text trace-window)
          (my-display exp)
          (newline trace-window)
          (trace-into?))

#f))

(result

(cond

((self-evaluating? exp) (env 'deceval) exp)

((quoted? exp) (env 'deceval) (text-of-quotation exp))

((variable? exp)

(((env 'deceval) 'lookup-variable-value) exp))

((definition? exp)

(eval-definition exp env (1+ insprong) trace-next-into))

((assignment? exp)

(eval-assignment exp env (1+ insprong) trace-next-into))

((lambda? exp)

(let ((r (create-procedure exp env)))

(env 'deceval) r))

((conditional? exp)

(eval-cond (clauses exp) env (1+ insprong) trace-next-into))

((let? exp) (eval-let exp env (1+ insprong) trace-next-into))

((if? exp) (eval-if exp env (1+ insprong) trace-next-into))

((begin? exp)
(eval-begin exp env (1+ insprong) trace-next-into))

        ((application? exp)
         (let* ((operat
                  ((garbage-collector 'push-sleeps)
                    (evaluate
                      (operator exp)
                      env
                      (1+ insprong)
                      "Evalueer operator "
                      trace-next-into)))
                (oprnds

(list-of-values

(operands exp)

env

(1+ insprong)

trace-next-into))

(result #f))

(env 'deceval)

(set! result

(apply-proc operat oprnds (1+ insprong) trace-next-into))

((garbage-collector 'remove-sleeps-head)

(1+ (length oprnds)))

result))

(else (error "Unknown expression type -- EVAL" exp)))))

    (if trace-into
      (begin
        (set-x-position insprong)
        (display "Result " trace-window)

(my-display exp)

(display " -> " trace-window)

(my-display result)

(newline trace-window)))

((garbage-collector 'set-sleeps-top!) result)

result))

(define (apply-proc procedure arguments insprong trace-into)

(if (or (primitive-procedure? procedure)

(compound-procedure? procedure))

((procedure 'apply) arguments insprong trace-into)

(error "Unknown procedure type -- APPLY" procedure)))

Load, Reset! & Driver-loop

(define (load-loop fromfile trace-into)

(define input (read fromfile))

(if (eof-object? input)

(let ((result

(evaluate

input

global-environment

"Evalueer file-section "

trace-into)))

(load-loop fromfile trace-into))))

(define (reset? exp)

(and (pair? exp) (eq? (car exp) 'RESET!)))

(define global-environment #f)

(define (reset!)
(envniveaus 'reset!)
(garbage-collector 'reset!)
(diagrammen 'reset!)

(set! global-environment (create-environment))

(global-environment 'inceval))

(define (driver-loop)

(newline trace-window)

(display "GMC -> " trace-window)

(let ((readexp (read trace-window)))

(if (reset? readexp)

(reset!)

(my-display

(evaluate

readexp

global-environment

"Evalueer programma "

#t))))

(driver-loop))

Trace-window & main-loop

(define trace-window-size 8)

(define trace-window-top #f)

(define trace-window (make-window))

(define (press-any-key)

(flush-input)

(if (eq? (char->integer (read-char)) 0) (read-char))

#t)

(define (make-pcs-status-invisible)

(%reify-port! pcs-status-window 11

(bitwise-and (%reify-port pcs-status-window 11) -11)))

(define (init-trace-window)

(let* ((ysize-normaltext

(+ 1 (car (window-get-position 'console))

(car (window-get-size 'console))))

(lettergrootte (/ (1+ (y maxcoor)) ysize-normaltext)))

(window-set-position! trace-window

(- ysize-normaltext trace-window-size) 0)

(set! trace-window-top

(- (y maxcoor) (* lettergrootte trace-window-size)))

(window-set-attribute! trace-window 'text-attributes 78)

(window-clear trace-window)

(window-set-cursor! trace-window (-1+ trace-window-size) 0)))

(define (set-x-position xp)

(window-set-cursor!

trace-window

(car (window-get-cursor trace-window))

xp))

(define (shift-pressed?)

(let ((keystate (peekbyte 1047)))

(or (odd? keystate)

(odd? (quotient keystate 2)))))

(define (trace-into?)
(let ((char (char->integer (read-char))))
(cond ((eq? char 0)

(set! char (read-char))

(cond ((eq? char '#\B) #f)

((eq? char '#\A) #t)

((eq? char '#\G)

(diagrammen 'home)

(trace-into?))

((eq? char '#\H)

((diagrammen 'move-up) (shift-pressed?))

(trace-into?))

((eq? char '#\P)

(diagrammen 'move-down) (shift-pressed?))

(trace-into?))

((eq? char '#\M)

                  ((diagrammen 'move-right) (shift-pressed?))
                  (trace-into?))
                 ((eq? char '#\K)
                  ((diagrammen 'move-left) (shift-pressed?))
                  (trace-into?))

(else (trace-into?))))

((eq? char 32) #t)

((eq? char 13) #f)

(else (trace-into?)))))

(define (about)

(let ((mid-point (make-point (/ (x maxcoor) 2) (/ (y maxcoor) 2))))

(define (iter count)

(set-color (1+ (my-random (-1+ maxcolor))))

(set-text-style 'DEFAULT 'horiz 5)

(set-text-justify 'CENTER 'BOTTOM)

(out-text-xy mid-point "GMC")

(set-text-justify 'CENTER 'TOP)

(set-text-style 'DEFAULT 'horiz 1)

(out-text-xy mid-point

"Een Grafische Meta-Circulaire Scheme evaluator")

(set-text-justify 'CENTER 'BOTTOM)

(out-text-xy (make-point (x mid-point) (- (y maxcoor) 45))

"Made by Werner Van Belle 1994")

(set-text-justify 'LEFT 'TOP)

(if (> count 0) (iter (-1+ count))))

(make-pcs-status-invisible)

(clear-device)

(iter 30)))

(define (main-loop)

(randomize)

(init-screen)

(if (= maxcolor 1) (Shit-mono!))

(about)

(init-trace-window)

(reset!)

(driver-loop))

(main-loop)