Inleiding
Onderstaande
source is grondig gedocumenteerd. Bij elke functie staat de invoer,
uitvoer en
eventuele comments vooraf vermeld. De source was oorspronkelijk
gedocumenteerd
in een soort 'project-farde' waarin gewoon alles
sequentieel bijgehouden werd. Door deze techniek toe te passen ben ik
in staat
geweest al de testen die ik uitgevoerd heb in de source aan te geven.
De documentatie
is als volgt
In : <type> parameter1,
<type> parameter2
Out : <type>, <betekenis>
Comments
: ...
(define (.... parameter1 parameter2)
...)
De gebruikte
types zijn
Angle
: een reëel getal dat een hoek voorstelt. Uitgedrukt in radialen.
(tussen 0 en 
)
Bool
: booleaanse waarde : #t of #f
Circle :
een
cirkel-segment, gecreëerd door make-circle
Color :
kan black, blue,
red, green, white, grey, dark-grey, 'light-grey, light-blue,
light-green, cyan, magenta, yellow... zijn.
Cons-cel
: enkelvoudige cons-cel
Error
: een resultaat aangemaakt met make-error
Grens
: een reëel getal. Oorspronkelijk was het de bedoeling dat een grens
ook een
open/gesloten parameter meekreeg.
Interval
: een interval bestaande uit twee reële getallen.
Line
: het type line (zie line)
Nothing
: is een type dat steeds wordt weergegeven. dit wil zeggen dat het
resultaat
totaal geen belang heeft.
Open-graph-set
: zie
(open-graph-set)
Point :
het type point. (zie point)
Real
: een reëel getal van scheme
Something
: een parameter waarvan het type niet gekend is krijgt het type
something
toegewezn.
Terminal
: Een armuiteinde. Meestal worden deze gemaakt met create-terminal
Vaak wordt self
vermeld. Dit is de verwijzing naar
de huidige dispatcher waarmee gewerkt wordt. Soms wordt een functie
voorafgegaan door een %-teken. Bijvoorbeeld %makeb.
Dit %-teken toont aan dat de functie wel globaal gedefinieerd is maar
dat ze
best door een beperkt aantal functies aangeroepen wordt. Soms slaat het
%-teken
ook op een onverwacht gedrag van de functie.
Welke functies
heb ik buiten hun -closure gebracht ?
Functies
die symmetrisch werken op 2 objecten : =p,
intersect-p-p?, ...
Identificerende
functies :
point?, line?, ...
Al
de intersectie-functies omdat deze werken op twee objecten en dus als
het waren
evenveel data van het ene object als het andere nodig hebben. Een soort
symmetrie dus : intersect-l-p?,
intersect-l-l
Abstracte definities wiskundige
objecten, lijnen, punten, grafische set's...
Algemeen
In : point p1, point p2
Out : real, de afstand tussen p1 en p2 volgens de Euclidische Metriek.
Comments : 
(define (euclid p1 p2)
(sqrt (+ (sqr (- (p1 'x) (p2 'x)))
(sqr (- (p1 'y) (p2 'y))))))
In : bool a, bool b
Out : real, a xor b
(define (xor a b)
;non-lazy
(or (and (not a) b)
(and a (not b))))
In : real a
Out : real, 
In : real a, real b, real
c
Out : cons-cel, oplossing van de vierkantsvergelijking
Comments : indien de vkv geen oplossingen heeft wordt een
'(#f.#f) weergegeven,
indien ze slechts één oplossing heeft een '(x.#f) en als ze twee
oplossingen
heeft 
(define (solve-vkv a b c)
(let ((D (- (sqr b) (* 4 a c))))
(cond ((< D 0) (cons #f
#f))
((=
D 0) (cons (/ (- b) (* 2
a)) #f))
(else
(cons (/ (- (- b) (sqrt
D)) (* 2 a))
(/ (- (sqrt
D) b) (* 2 a)))))))
Definitie van vaak
gebruikte constanten.
(define PI/2 (/ PI 2))
(define 3PI/2 (/ (* PI 3) 2))
(define 2PI (* PI 2))
Definitie van de
type-nummers. Deze nummers zijn nodig om nadien de snijding tussen twee
'onbekende' objecten te kunnen dirigeren.
(define point-id 1)
(define line-id 2)
(define circle-id 3)
(define graph-set-id 4)
(define closed-graph-set-id 5)
De grid is de resolutie
waarmee het programma werkt. Indien de resolutie te groot is zullen er
underflows en overflows optreden.
Hoeken
De berekeningen
met hoeken worden hier behandeld. Deze zijn nodig om nadien rotaties te
kunnen
uitvoeren en ook in geringe mate om de verschillen in Bgcos/Bgsin van
de ene
scheme-implementatie naar de andere op te heffen.
In : point center, real radius,
angle angle
Out : point result, dat op afstand radius van center ligt en waarbij de
halfrechte [center,result> een hoek angle
vormt met de horitzontale.
(define (realize-angle center radius
angle)
(make-point
(+ (center 'x) (* radius (cos
angle)))
(+ (center 'y) (* radius (sin
angle)))))
In : point center, point p
Out : point result, bepaalt de hoek
tussen de horizontale en de halfrechte [center,p>
(define (angle-of center p)
(let ((dx (- (p 'x) (center 'x)))
(dy
(- (p 'y) (center 'y))))
(cond ((> dx 0)
(cond ((> dy 0) (atan (/
dy dx)))
((= dy 0) 0)
(else (- 2PI (atan (/
(- dy) dx))))))
((=
dx 0)
(cond ((> dy 0) PI/2)
((= dy 0) (error
"Can't find angle..."))
(else 3PI/2)))
(else
(cond ((> dy 0) (- PI
(atan (/ dy (- dx)))))
((=
dy 0) PI)
(else (+ PI (atan (/
dy dx)))))))))
Punten
|
Points
|
|
name & parameters
|
action
|
|
make-point x
y
|
Creëert een punt
met coordinaten x en y. Het punt wordt vanzelf geconverteerd naar een
grid. (met resolutie GRID)
|
|
x; y
|
Vraagt de
x-coordinaat/y-coordinaat van het punt op.
|
In : nothing
Out : nothing
Comments : print self af onder de vorm
"(x,y)"
(define
(display-point)
(message "(" x
"," y ")"))
In : color color
Out : nothing
Comments : tekend self met kleur color,
indien color 'ownstyle is wordt
de std-point-color gebruikt.
(define
(show-point color)
(put-pixel point (if (eq?
color
'ownstyle) std-point-color color)))
In : point vct
Out : point r
Comments : r is het resultaat na self te verplaatsen over een afstand vct
(define
(translate vct)
(make-point (+ x (vct 'x)) (+
y (vct
'y))))
In : point around, angle angle
Out : point r
Comments : r is het beeld van self
door de rotatie-operatie met
fixpunt around en hoek angle
(define (rotate
around angle)
(if (and (= x (around 'x)) (=
y
(around 'y)))
(make-point
x y)
(let*
((dist (euclid around
point))
(angle-before (angle-of
around point)))
(realize-angle
around dist (+
angle-before angle)))))
In : point howmuch
Out : line r
Comments : r is het lijnstuk dat ontstaat
door self te verplaatsen over de
afstand howmuch.
(define
(translate-sleep howmuch)
(make-line point (translate
howmuch)))
In : point around, angle angle
Out : circle r
Comments : r is het cirkelsegment dat
ontstaat door self te roteren rond around
over een hoek angle
(define
(rotate-sleep around angle)
(if (and (= x (around 'x)) (=
y
(around 'y)))
(make-point
x y)
(let*
((dist (euclid around
point))
(angle-before (angle-of
around point)))
(make-circle
around dist
angle-before (+ angle-before angle)))))
(define
(point m)
(cond ((eq? m 'x) x)
((eq?
m 'y) y)
((eq?
m 'x-int) (make-interval
x x))
((eq?
m 'y-int) (make-interval
y y))
((eq?
m 'display)
(display-point))
((eq?
m 'type-number)
point-id)
((eq?
m 'show) show-point)
((eq?
m 'rotate) rotate)
((eq?
m 'translate) translate)
((eq?
m 'translate-sleep)
translate-sleep)
((eq?
m 'rotate-sleep)
rotate-sleep)
(else
(error "unkown
message - POINT" m))))
Initialisatie
Hier worden de
coordinaten omgezet naar de grid zodat er geen underflows/overflows
worden
gegenereerd.
Uiteindelijk wordt self weergegevn
(set! x (* GRID
(round (/ x GRID))))
(set! y (* GRID (round (/ y GRID))))
point)
In : something p
Out : bool
Comments : geeft #t weer indien p een
punt is, geeft #f weer indien p geen
punt is.
(define (point? p)
(eq? (p 'type-number) point-id))
In : point p1, point p2
Out : bool
Comments
: Geeft weer of 
(define (=p p1 p2)
(and (= (p1 'x) (p2 'x))
(= (p1 'y)
(p2 'y))))
In : point p1, point p2
Out : open-graph-set r
Comments : Deze functie controleert of p1
en p2 samen vallen, dus snijden, en
geeft dan het resultaat van de snijding in de vorm van een
open-graph-set weer.
(define (Intersect-p-p p1 p2)
(if (=p p1 p2)
(graph-set p1)
(graph-set)))
Interval
Een interval
wordt gebruikt in alle eindige strukturen die zowel een beginpunt als
een
eindpunt hebben. Oorspronkelijk was deze gedefinieerd zodat het type
grens kon
meegegeven worden. (Open of gesloten). Ik heb deze mogelijkheid
verwijderd
zodat het programma sneller draait. De oorspronkelijke definitie van
een
interval volgt een beetje later.
In : grens from-grens, grens to-grens
Out : interval r
Comments : Het ADT Interval is gedefinieerd als een
struktuur met een verzameling
operaties. Door deze niet als een lambda te definieren maak ik een
forse
geheugenwinst en verbetering in berekenings-snelheid.
Zowel de from-grens als de to-grens behoren beiden tot het interval.
Dus
volledig gesloten.
(define (make-interval from-grens
to-grens)
(cons from-grens to-grens))
In : interval interval
Out : grens from-grens van
interval interval
(define (from-grens interval)
(car interval))
In : interval interval
Out : grens to-grens van
interval interval
(define (to-grens interval)
(cdr interval))
In : interval i
Out : bool b
Comments : Indien het meegegeven interval slechts uit één
punt bestaat wordt #t
weergegeven, in het andere geval wordt #f geretourneerd.
(define (punt-interval? i)
(= (from-grens i) (to-grens i)))
In : interval who
Out : nothing
Comments : print het interval af onder de vorm "[from,to]"
(define (display-interval who)
(message "[" (from-grens
who) "," (to-grens who) "]"))
In : interval interval
Out : interval r
Comments : r is het interval dat voldoet
aan de voorwaarde 
. Omdat dit
ADT enkel functioneel gebruikt kan worden moet er geen copie gemaakt
worden
indien het interval reeds geordend is.
(define
(orden-interval interval)
(if (> (from-grens interval)
(to-grens interval))
(make-interval
(to-grens interval)
(from-grens interval))
interval))
In : real p, interval CD
Out : bool r
Comments : indien p op het interval CD ligt zal #t worden weergegeven. #f in
het andere geval. Merk op dat CD als
gesloten interval beschouwd wordt.
(define (punt-op-interval?
p CD)
(set! CD
(orden-interval CD))
(and (>= p (from-grens CD))
(<= p
(to-grens CD))))
In : interval AB, interval CD
Out : interval result
Comments : deze functie maakt de snijding van twee
intervallen. Geen van beide moet
op voorand geordent zijn.
(define (intersect-interval AB CD)
(define (%intersect-interval A B C D)
(cond ((> A B)
(%intersect-interval B A C D))
((>
C D)
(%intersect-interval A B D C))
((<
C A)
(%intersect-interval C D A B))
((<=
D B) (make-interval C
D))
((<=
C B) (make-interval C
B))
((and
(= B C)) (make-interval
B B))
(else
#f)))
(%intersect-interval
(from-grens AB) (to-grens AB)
(from-grens CD) (to-grens
CD)))
Definitie van het
eenheidsinterval
(define I1 (make-interval 0 1))
Lijnen
|
Lines
|
|
name & parameters
|
action
|
|
make-line from-p,
to-p
|
Maakt een lijn van from-p naar to-p. Hierbij zijn from-p en to-p punten die gemaakt zijn
met make-point.
|
|
from-p; to-p
|
Vraagt het van-punt
en het naar-punt van de lijn op.
|
|
from-x; from-y; to-x; to-y
|
Vraagt
respectievelijk : de x-coordinaat van from-p,
y-coordinaat van from-p, x-coordinaat van to-p,
y-coordinaat van to-p op.
|
|
dx; dy
|
Geeft het verschil
op de x/y-as.
|
|
dx/dy; dy/dx
|
Geeft de
richtingscoëfficient van de rechte en het omgekeerde van de rico weer.
|
|
horizontal?;
vertikal?
|
Zegt of een lijn
als horizontaal/vertikaal behandeld mag worden.
|
|
fast-point-op? p
|
Geeft #t weer als p.x in x-int valt en p.y in y-int valt.
|
|
point-in-range? p
|
Geeft #t weer als p op de rechte door from-p en to-p zou vallen.
|
|
x@y; y@x
|
x@y geeft de
x-coordinaat die hoort bij een bepaalde y-coordinaat. y@x doet
vanzelfsprekend het omgekeerde.
|
Dit is de definitie
van een lijn. Normaal kon je hier bij geven of het begin/eindpunt tot
het
lijnstuk behoorde of niet.
(define (make-line from-p to-p)
In : Nothing
Out : x-coordinaat from-point
(define
(from-x)
(from-p 'x))
In : Nothing
Out : y-coordinaat from-point
(define
(from-y)
(from-p 'y))
In : Nothing
Out : x-coordinaat to-point
(define
(to-x)
(to-p 'x))
In : Nothing
Out : y-coordinaat to-point
(define
(to-y)
(to-p 'y))
In : Nothing
Out : real dx/dy
(define
(dx/dy)
(/ (dx) (dy)))
In : Nothing
Out : real dy/dx
(define
(dy/dx)
(/ (dy) (dx)))
In : Nothing
Out : real dx
(define
(dx)
(- (to-x) (from-x)))
In : Nothing
Out : real dy
(define
(dy)
(- (to-y) (from-y)))
In : Nothing
Out : bool r
Comments : geeft #t weer indien het een horizontale
rechte/lijnstuk is.
(define
(horizontaal?)
(= (to-y) (from-y)))
In : Nothing
Out : bool r
Comments : geeft #t weer indien het een vertikale
rechte/lijnstuk is.
(define (vertikaal?)
(= (to-x) (from-x)))
In : Nothing
Out : Nothing
Comments : print de lijn af onder de vorm "(from-p,to-p)"
(define (display-line)
(message "(")
(from-p 'display)
(message ",")
(to-p 'display)
(message ")"))
In : Nothing
Out : Nothing
Comments : tekent self op het scherm.
Indien color 'ownstyle is wordt een std-line-color
gebruikt
(define (show-line color)
(set-color (if (eq? color
'ownstyle)
std-line-color color))
(line from-p to-p))
In : point p
Out : bool r
Comments : geeft #t weer indien p op de rechte
ligt. Belangrijk is dat hierbij p
niet binnen de grenzen van self moet
vallen.
(define
(point-in-range? p)
;dy
dx acftie
;---------------------
; 0
/ y controleren
; /
0 x controleren
; /
/ gewoon de waarden invullen
(let ((x1 (from-x))
(x2
(to-x))
(y1
(from-y))
(y2
(to-y)))
(cond ((= x2 x1)
(= x1 (p 'x)))
((= y1 y2) (= y1 (p 'y)))
(else
(=
(* (- (p 'y) y1) (- x2
x1))
(* (- (p 'x) x1) (- y2
y1)))))))
In : point p
Out : bool r
Comments : geeft #t weer indien p in het vierkant
bepaalt door from-p en to-p ligt.
(define
(fast-point-op? p)
(and (punt-op-interval? (p
'x)
(make-interval (from-x) (to-x)))
(punt-op-interval?
(p 'y)
(make-interval (from-y) (to-y)))))
In : point p
Out : bool r
Comments : geeft #t weer indien p op self
ligt
(define
(punt-op? p)
(if (point-in-range? p)
(fast-point-op? p)))
In : real y
Out : real x
Comments : geeft de x-coordinaat weer die hoort bij een
bepaalde y-positie. Deze
operator werkt niet bij horizontale lijnen. Zoals de tekening aantoont
werkt
deze functie ook buiten het interval [from-p,to-p]
(define
(x@y y)
(+ (from-x) (* (- y (from-y))
(dx/dy))))
In : real x
Out : real y
Comments : geeft de y-coordinaat weer die hoort bij een
bepaalde x-positie. Deze
operator werkt niet bij vertikale lijnen. Deze functie ook buiten het
interval
[from-p,to-p]
(define (y@x x)
(+ (from-y) (* (- x (from-x))
(dy/dx))))
In : point p
Out : bool r
Comments : geeft #t weer indien p gelijk
is aan from-p. Dit wordt niet getest
door de pointers te vergelijken maar wel door de getalwaarden te
controleren.
(define
(from-eindpunt? p)
(=p p from-p))
In : point p
Out : bool r
Comments : geeft #t weer indien p gelijk
is aan to-p. Deze wordt weeral
vergeleken door de getalwaarden te checken.
(define
(to-eindpunt? p)
(=p p to-p))
In : Nothing
Out : 'up/'down
Comments : Deze functie is voor intern gebruik. Ze
wordt aangeroepen door nulpunten@horizon om te
controleren naar
waar de lijn vertrekt. Indien to-p
hoger ligt dan from-p (dus 
) dan wordt
'down weergegeven. 'up in het andere
geval.
(define
(to-direction)
(if (> (to-p 'y) (from-p
'y))
'down
'up))
In : real horizon
Out : list of nulpunten
Comments : Geeft een verzameling van nulpunten weer. Bij
een lijn (hier dus) kan er
maar 1 nulpunt zijn. Het resultaat wordt als volgt bepaalt
self ligt boven/onder horizon : geen
nulpunt
self raakt aan de horizon en vertrekt
naar boven : (x 1 0)
self raakt horizon en vertrekt naar
beneden : (x 0 1)
self snijdt de horizon : (x 1 1)
(define
(nulpunten@horizon horizon)
(let ((ip (intersect-l-l
(make-horizon horizon) line-object)))
(cond ((ip
'empty?) '()) ;gewoon
geen snijpunt
((begin (set! ip (ip
'singleton)) #f)
(error "Unreachable
code"))
((line? ip) '())
;samenvallenden
((from-eindpunt? ip) ;van
from naar boven of beneden
(if (eq? (to-direction)
'up)
(list (make-nulpunt (ip
'x) 1 0))
(list (make-nulpunt (ip
'x) 0 1))))
((to-eindpunt? ip) ;van
to naar boven of beneden
(if (eq? (to-direction)
'down)
(list (make-nulpunt (ip
'x) 1 0))
(list
(make-nulpunt (ip 'x) 0 1))))
(else
;zowel naar boven als
beneden
(list (make-nulpunt (ip 'x)
1 1))))))
In : nothing
Out : interval r
Comments : het geretourneerde interval r
geeft de projectie van de lijn op de X-as weer.
(define (x-int)
(let ((x1 (from-p 'x))
(x2
(to-p 'x)))
(if (> x1 x2)
(make-interval
x2 x1)
(make-interval
x1 x2))))
In : nothing
Out : interval r
Comments : het geretourneerde interval r
geeft de projectie van de lijn op de Y-as weer.
(define (y-int)
(let ((y1 (from-p 'y))
(y2
(to-p 'y)))
(if (> y1 y2)
(make-interval
y2 y1)
(make-interval
y1 y2))))
In : point vct
Out : line
Comments : self wordt over afstand vct verschoven. Een nieuwe lijn wordt
gecreëerd.
(define (translate
vct)
(make-line
((from-p
'translate) vct)
((to-p
'translate) vct)))
In : point center, angle angle
Out : line
Comments : self wordt over een hoek angle gedraait waarbij het middelpunt center
is. Een nieuwe lijn wordt
gecreëerd.
(define (rotate
center angle)
(make-line
((from-p 'rotate)
center angle)
((to-p 'rotate)
center angle)))
In : point howmuch
Out : closed-graph-set
Comments : het resultaat is de gesloten-graph-set die
ontstaat door self te verschuiven over howmuch
(define
(translate-sleep howmuch)
(closed-graph-set
line-object
((to-p
'translate-sleep) howmuch)
(translate
howmuch)
((from-p
'translate-sleep)
howmuch)))
(define
(line-object m)
(cond ((eq? m 'from-p) from-p)
((eq?
m 'to-p) to-p)
((eq?
m 'from-coef)
(from-coef))
((eq?
m 'to-coef) (to-coef))
((eq?
m 'from-x) (from-x))
((eq?
m 'from-y) (from-y))
((eq?
m 'to-x) (to-x))
((eq?
m 'to-y) (to-y))
((eq?
m 'dx) (dx))
((eq?
m 'dy) (dy))
((eq?
m 'dx/dy) (dx/dy))
((eq?
m 'dy/dx) (dy/dx))
((eq?
m 'display)
(display-line))
((eq? m 'horizontaal?) (horizontaal?))
((eq?
m 'vertikaal?)
(vertikaal?))
((eq?
m 'punt-op?) punt-op?)
((eq?
m 'fast-point-op?) fast-point-op?)
((eq?
m 'point-in-range?)
point-in-range?)
((eq?
m 'x@y) x@y)
((eq?
m 'y@x) y@x)
((eq?
m 'type-number) line-id)
((eq?
m 'show) show-line)
((eq?
m 'x-int) (x-int))
((eq?
m 'y-int) (y-int))
((eq?
m 'nulpunten@horizon)
nulpunten@horizon)
((eq?
m 'translate) translate)
((eq?
m 'rotate) rotate)
((eq?
m 'translate-sleep)
translate-sleep)
(else
(error "Unkown
message - line" m))))
Initialisatie van een lijn-object. Eerst wordt gecontroleerd of
from-p niet gelijk is aan to-p. Anders zouden er nadien wel eens rare
error's
kunnen optreden. Indien ze gelijk zijn wordt gewoon het punt
weergegeven.
(if (=p from-p to-p)
from-p
line-object))
In : Something l
Out : bool r
Comments : geeft weer of l een lijn is.
(define (line? l)
(eq? (l 'type-number) line-id))
In : real horizon
Out : line r
Comments : creëert een horizon op hoogte horizon.
(define (make-horizon horizon)
(make-line (make-point -1000000
horizon) (make-point +1000000 horizon)))
In : line l, interval new-interval
Out : line result
Comments : l zijn begin en eindpunt
worden verplaatst zodat de lengte van result
gelijk is aan de grootte van new-interval.
Deze functie wordt aangeroepen vanuit intersect-line.
(define (change-interval l
new-interval)
(let ((x1 (l 'from-x))
(y1
(l 'from-y))
(dx
(l 'dx))
(dy
(l 'dy)))
(define (give-point
factor)
(make-point
(+
(* factor dx) x1)
(+
(* factor dy) y1)))
(make-line
(give-point
(from-grens new-interval))
(give-point
(to-grens
new-interval)))))
In : line linevan, line normline
Out : interval r
Comments : Deze functie geeft een interval weer waarmee linevan en normline vergeleken kunnen
worden. Dit is nodig om bij het snijden
van samenvallende rechten het resultaat-interval te berekenen.
(uiteindelijk
zal het resultaatinterval weer op de normline
gemapt worden door de functie change-interval).
Als je de functie aanroept met linevan=normline
zal het eenheidsinterval weergegeven worden.
Belangrijk : deze bewerking is niet commutatief
(define (normeer-line linevan
normline)
(define (%normeer-line x1 x2 a1 a2)
(let ((c->d (- x2 x1))
(a->b
(- a2 a1))
(a->c
(- x1 a1)))
(make-interval (/
a->c a->b)
(/ (+ c->d a->c) a->b))))
(if (> (abs (normline 'dx)) (abs
(normline 'dy)))
(%normeer-line
(linevan 'from-x)
(linevan 'to-x)
(normline 'from-x)
(normline 'to-x))
(%normeer-line
(linevan 'from-y)
(linevan 'to-y)
(normline
'from-y)(normline 'to-y))))
In : line l, point p
Out : open-graph-set r
Comments : Controleert of p op l
valt en geeft (indien wel) een
graph-set weer met p in. Anders wordt
de lege verzameling weergegeven.
(define (intersect-l-p l p)
(if ((l 'punt-op?) p)
(graph-set p)
(graph-set)))
In : line l1, line l2
Out : open-graph-set gs
Comments : gs bevat ofwel
Niets
: de lijnen snijden niet
Een
punt : de lijnen snijden in dat specifieke punt
Een
lijn : de lijnen vallen samen
Het resultaat houdt
rekening met het bereik van elk lijnstuk. l1
en l2 worden dus niet als rechten
beschouwd. Hoe het resultaat wordt berekend staat vermeld in
onderstaande
tabel.
|
dx1
|
dy1
|
dx2
|
dy2
|
action
|
|
0
|
/
|
0
|
/
|
// of samenvallende rechten
|
|
0
|
/
|
/
|
0
|
Snijden @ (x lijn 1, y lijn 2)
|
|
0
|
/
|
/
|
/
|
y@x L2 xlijn1
|
|
/
|
0
|
0
|
/
|
Snijden @ (x lijn 2, y lijn 1)
|
|
/
|
0
|
/
|
0
|
// of samenvallende rechten
|
|
/
|
0
|
/
|
/
|
x@y L1 ylijn2
|
|
/
|
/
|
0
|
/
|
[recurse] omdraaien en aanroepen
|
|
/
|
/
|
/
|
0
|
[recurse] omdraaien en aanroepen
|
|
|
Evenwijdige of samenvallende
|
|
|
Snijden
|
(define (intersect-l-l
l1 l2)
In : Nothing
Out : open-graph-set
Comments : Onderstaande functie wordt aangeroepen als
geweten is dat l1 en l2 samenvallen.
Hiervoor moeten een paar intervallen gesneden
worden en het resultaat in een open-graph-set gestoken.
(define
(samenvallende)
(let ((new-interval
(intersect-interval I1 (normeer-line l2 l1))))
(if new-interval
(graph-set
(change-interval l1
new-interval))
(graph-set))))
In : Nothing
Out : open-graph-set
Comments : Deze interne werker geeft de lege verzameling
weer. Hij wordt opgeroepen
op het ogenblik dat geweten is dat de lijnen evenwijdig zijn.
(define
(evenwijdige)
(graph-set))
In : point s
Out : open-graph-set
Comments : Deze interne functie wordt wakker geschud als
het hypothetische snijpunt
berekend is. Hetgeen hier nog gebeurt is de controle dat s
zowel op l1 als op l2 ligt. Dit kan
gecontroleerd worden
met de fast-point-op? omdat het
snijpunt zodanig berekend is dat het zeker op de rechten l1 & l2 zal vallen. Dit zorgt voor
performantie-winst !
Het resultaat is een lege verzameling als s niet op één van beide
lijnen valt
en is de verzameling met s in als s
op beide lijnstukken valt.
(define (snijpunt s)
(if (and ((l1
'fast-point-op?) s)
((l2 'fast-point-op?) s))
(graph-set
s)
(graph-set)))
Hier begint dan de
echte hel voor de programmeur. Namelijk het implementeren van de
snijding...
|
dx1
|
dy1
|
dx2
|
dy2
|
action
|
|
0
|
/
|
0
|
/
|
// of samenvallende rechten
|
|
0
|
/
|
/
|
0
|
Snijden @ (x lijn 1, y lijn 2)
|
|
0
|
/
|
/
|
/
|
y@x L2 xlijn1
|
(cond
((l1 'vertikaal?)
(cond
((l2 'vertikaal?)
(if
(= (l1 'from-x) (l2 'from-x))
(samenvallende)
(evenwijdige)))
((l2 'horizontaal?)
(snijpunt (make-point
(l1 'from-x) (l2 'from-y))))
(else
(snijpunt
(make-point (l1
'from-x) ((l2 'y@x) (l1 'from-x)))))))
|
dx1
|
dy1
|
dx2
|
dy2
|
action
|
|
/
|
0
|
0
|
/
|
Snijden @ (x lijn2, y lijn1)
|
|
/
|
0
|
/
|
0
|
// of samenvallende rechten
|
|
/
|
0
|
/
|
/
|
x@y L1 ylijn2
|
((l1 'horizontaal?)
(cond
((l2 'vertikaal?)
(snijpunt
(make-point (l2 'from-x) (l1 'from-y))))
((l2 'horizontaal?)
(if (= (l1 'from-y) (l2
'from-y))
(samenvallende)
(evenwijdige)))
(else
(snijpunt
(make-point ((l2 'x@y) (l1 'from-y)) (l1
'from-y))))))
|
dx1
|
dy1
|
dx2
|
dy2
|
action
|
|
/
|
/
|
0
|
/
|
y@x L1 L2x
|
|
/
|
/
|
/
|
0
|
x@y L2 L1y
|
|
|
Evenwijdige of samenvallende
|
|
|
Snijden
|
(else
(cond
((l2 'vertikaal?)
(snijpunt
(make-point (l2
'from-x) ((l1 'y@x) (l2 'from-x)))))
((l2 'horizontaal?)
(snijpunt
(make-point ((l1 'x@y)
(l2 'from-y)) (l2 'from-y))))
(else
(let* ((x1 (l1 'from-x)) (y1 (l1 'from-y))
(x2 (l1 'to-x))
(y2 (l1 'to-y))
(a1 (l2 'from-x))
(b1 (l2 'from-y))
(a2 (l2 'to-x))
(b2 (l2 'to-y))
(dx1
(- x2 x1)) (dy1 (- y2
y1))
(dx2 (- a2
a1)) (dy2 (- b2 b1))
(m1 (/ dy1
dx1)) (m2 (/ dy2 dx2))
(B (* dy1
dx2)) (C (- (* dy2
dx1))))
(if (= (+ B C) 0) ;evenwijdig of samenvallende
(if ((l1
'point-in-range?) (l2 'from-p))
(samenvallende)
(evenwijdige))
(let* ((A (* dx1
dx2 (- b1 y1)))
(x (/ (+ A
(* x1 B) (* a1 C))
(+ B
C)))
(y (+ y1
(/ (* (- x x1) dy1) dx1))))
(snijpunt
(make-point x y))))))))))
In : line l1, line l2
Out : bool r
Comments : geeft #t weer indien l1 snijdt
met l2, #f in het andere geval.
(define (intersect?-l-l l1 l2)
(not ((intersect-l-l l1 l2) 'empty?)))
Cirkels
|
Circles
|
|
name & parameters
|
action
|
|
make-cirlce center
radius from-angle to-angle
|
Maakt een circle
met middelpunt center en straal radius.
Enkel het stuk boog van from-angle tot en met to-angle wordt gebruikt. Indien to-angle=2PI
en from-angle=0 dan wordt de volledige
cirkel beslagen.
|
|
radius; center;
from-angle; to-angle
|
Vragen
respectievelijk straal, middelpunt, van-hoek en naar-hoek op.
|
|
center-x; center-y
|
Vraagt de
x/y-coordinaat op van het middelpunt.
|
|
angle-of p
|
Vraagt van een
meegegeven punt de hoek op die gevormd wordt met het centrum en de
horizontale. Het antwoord is een georienteerde hoek.
|
|
point@angle angle
|
Vraagt het punt van
de cirkel op hoek angle op
|
|
fast-point-op? p
|
Geeft weer of een
punt in de sector bepaalt door from-angle tot to-angle ligt.
|
(define (make-circle center radius
from-angle
to-angle)
In : nothing
Out : real x
Comments : geeft de x-coordinaat van het centrum weer.
(define (center-x)
(center 'x))
In : nothing
Out : real y
Comments : geeft de y-coordinaat van het centrum weer.
(define (center-y)
(center 'y))
In : angle a
Out : angle n
Comments : geeft een nieuwe hoek naar buiten waarbij n in 
ligt. Let op het feit
dat 
ook tot het interval
behoort. Dit maakt het
mogelijk een volledige cirkel te definiëren.
(define
(normalize-angle a)
(if (> a 2PI)
;duidelijk een strikte ongelijkheid...
(normalize-angle
(- a 2PI))
a))
In : angle a
Out : point r
Comments : Vraagt het punt van de cirkel op hoek a
op
(define (point@angle
a)
(realize-angle center radius
a))
In : angle a
Out : bool r
Comments : Vraagt van een bepaalde hoek of hij op de
cirkelboog ligt, of niet.
(define (angle-op?
a)
(and (>= a from-angle)
(<= a
to-angle)))
In : angle a
Out : angle r
Comments : Vraagt van een meegegeven punt de hoek op die
gevormd wordt met het centrum en de horizontale. Het antwoord is een
georienteerde hoek
(define (%angle-of
p)
(angle-of center p))
In : point p
Out : bool r
Comments : Geeft weer of een punt in de sector bepaalt door
from-angle tot to-angle ligt.
(define
(fast-point-op? p)
(angle-op? (%angle-of p)))
In : nothing
Out : nothing
Comments
: print de circle af onder de vorm
"(center,fromangle,toangle)"
(define
(display-circle)
(message "(")
(center 'display)
(message ",")
(message from-angle)
(message ",")
(message to-angle)
(message radius))
In : color color
Out : nothing
Comments : Tekent de cirkel door gebruik te maken van ellipse. Door deze functie te gebruiken
zorg ik dat veranderde scaling geen probleem meer oplevert.
(define (show-circle
color)
(let ((fa (round (/ (*
from-angle
360) 2PI)))
(ta
(round (/ (* to-angle 360)
2PI))))
(set-color (if
(eq? color
'ownstyle) std-circle-color color))
(ellipse center
fa ta (make-point
radius radius))
))
(define
(circle-object m)
(cond ((eq? m 'radius) radius)
((eq?
m 'center) center)
((eq?
m 'center-x) (center-x))
((eq?
m 'center-y) (center-y))
((eq?
m 'from-angle)
from-angle)
((eq?
m 'to-angle) to-angle)
((eq? m 'fast-point-op?) fast-point-op?)
((eq?
m 'angle-of) %angle-of)
((eq?
m 'display)
(display-circle))
((eq?
m 'point@angle)
point@angle)
((eq?
m 'type-number)
circle-id)
((eq?
m 'show) show-circle)
(else
(error "Zapping
against zhe walls..." m))))
Initialisatie van een cirkel-object. Hierbij worden de hoeken
genormalizeerd en georiënteerd.
(set! from-angle
(normalize-angle from-angle))
(set! to-angle (normalize-angle
to-angle))
(if (> from-angle to-angle)
(let ((temp from-angle))
(set! from-angle
to-angle)
(set! to-angle
temp)))
circle-object)
In : something o
Out : bool b
Comments : geeft weer of o een cirkelboog
is of niet.
(define (circle? o)
(eq? (o 'type-number) circle-id))
In : point p, circle c
Out : graph-set s
Comments : Geeft een verzameling weer van de snijpunten die
ontstaan bij het snijden van p met c.
Dit is een gemakkelijke...
(define (intersect-p-c p c)
(if ((c 'punt-op?) p)
(graph-set p)
(graph-set)))
In : line l, circle c
Out : graph-set s
Comments : Geeft een verzameling weer van de snijpunten die
ontstaan door l met c te snijden. Er
worden 3 gevallen
beschouwd : l is horizontaal, l is
vertikaal en l loopt schuin.
(define (intersect-l-c l c)
(let ((answer (graph-set))
(b (c
'center-y))
(a (c
'center-x))
(r (c
'radius)))
(define (snijpunt s)
(if (and ((c
'fast-point-op?) s)
((l 'fast-point-op?) s))
((answer
'add!) s)))
(cond ((l 'vertikaal?)
(let*
((x (l 'from-x))
(bigc (+ (- (sqr r))
(sqr (- x a))
(sqr b)))
(bigb (* -2 b))
(result (solve-vkv 1
bigb bigc)))
(define (snijpunt@y y)
(if y (snijpunt
(make-point x y))))
(snijpunt@y (car result))
(snijpunt@y (cdr result))))
((l 'horizontaal?)
(let* ((y (l 'from-y))
(bigc (+ (- (sqr r))
(sqr (- y b))
(sqr a)))
(bigb (* -2 a))
(result (solve-vkv 1
bigb bigc)))
(define (snijpunt@x x)
(if x (snijpunt
(make-point x y))))
(snijpunt@x (car result))
(snijpunt@x (cdr result))))
(else
(let* ((x1 (l 'from-x))
(y1 (l 'from-y))
(m (l 'dx/dy))
(x1-a (- x1 a))
(m2 (sqr m))
(BigA (+ 1 m2))
(BigB (+ (* -2 y1 m2)
(* 2 m x1-a)
(* -2 b)))
(BigC (+ (sqr (- (*
y1 m) x1-a))
(sqr b)
(- (sqr
r))))
(result (solve-vkv
BigA BigB BigC)))
(define (snijpunt@y y)
(if y (snijpunt
(make-point ((l 'x@y) y) y))))
(snijpunt@y (car result))
(snijpunt@y (cdr
result)))))
answer))
In : circle c1, circle c2
Out : graph-set s
Comments : Er wordt een graph-set naar buiten gegeven die
al de snijpunten bevat tussen c1 en c2.
Er worden drie gevallen in
beschouwing genomen : samenvallende cirkels, concentrische cirkels en
gewoon
snijdende cirkels.
(define (intersect-c-c C1 C2)
(if (=p (C1 'center) (C2 'center))
;samenvallen of concentrisch
(if (= (C1
'radius) (C2 'radius))
;samenvallen,
nu nog de
angle-ntervallen snijden
(let
((f1 (C1 'from-angle))
(t1 (C1 'to-angle))
(f2 (C2 'from-angle))
(t2 (C2 'to-angle))
(i1 #f)
(i2 #f))
(if (< t1 f1) (set! t1 (+
t1 2PI)))
(if (< t2 f2) (set! t2 (+
t2 2PI)))
(set! i1 (make-interval f1
t1))
(set! i2 (make-interval f2
t2))
(set! i1 (intersect-interval
i1 i2))
(if i1
(graph-set (make-circle
(C1 'center)
(C1 'radius)
(from-grens
i1) (to-grens i1)))
(graph-set)))
(graph-set))
(let* ((a (C1 'center-x))
(b (C1 'center-y))
(c (C2 'center-x))
(d (C2 'center-y))
(BigB2 (+ (sqr (- c a))
(sqr (- d b))))
(Big-A2 (- (sqr (C2
'radius))))
(BigC (C1 'radius))
(BigB (sqrt BigB2))
(BigC2 (sqr BigC))
(toacos (/ (+ Big-A2 BigB2
BigC2) (* 2 BigB BigC))))
(if
(> (abs toacos) 1)
(graph-set) ;te ver van een
(let ((angle (acos toacos))
(answer (graph-set))
(stdhoek ((C1
'angle-of) (C2 'center))))
(define (snijpunt p)
(if (and ((C1
'fast-point-op?) p) ((C2 'fast-point-op?) p))
((answer 'add!) p)))
(snijpunt ((C1
'point@angle) (+ stdhoek angle)))
(snijpunt ((C1
'point@angle) (- stdhoek angle)))
answer)))))
Nulpunten
Nulpunten zijn
nodig om de graph-set toe te laten te controleren of een bepaald punt
begrensd
wordt door de objecten die het bevat. Daarom staat hier een mini-ADT.
In : real nulpuntpos, int pos-count,
int neg-count
Out : nulpunt nlpnt
Comments : De nulpunten worden gewoon opgeslagen in
lijst-vorm. Opvragen van de fields gebeurt met nulpunt-pos,
positiviteit
en negativiteit.
(define nulpunt-pos car)
(define positiviteit cadr)
(define negativiteit cddr)
(define (make-nulpunt nulpuntpos
pos-count
neg-count)
(cons nulpuntpos (cons pos-count
neg-count)))
In : nulpunt a, nulpunt b
Out : nulpunt c
Comments : geeft een nieuw nulpunt naar buiten waarbij de pos-counts van beide en de neg-counts
van beide zijn opgeteld. Deze
operatie heeft enkel zin als de nulpunt-posities
van beide gelijk zijn.
(define (merge-nulpunten a b)
(make-nulpunt
(nulpunt-pos a)
(+ (positiviteit a)
(positiviteit
b))
(+ (negativiteit a)
(negativiteit
b))))
Open
grafische verzamelingen
|
Open grafische verzameling : Graph-set
|
|
name & parameters
|
action
|
|
make-graph-set object-list
|
Maakt een
verzameling van grafische objecten. Object-list is een
scheme-lijst die de gewenste data bevat. Deze
objecten worden onafhankelijk van elkaar beschouwd, zodat er 'open'
vlakken ontstaan en geen 'gesloten'
|
|
punt-in? p
|
Geeft weer of punt p in de grafische verzameling valt, of niet. Dit is
nuttig als er een gesloten vlak wordt gecreëerd met lijnen.
|
|
empty?
|
Geeft #t weer
indien de set leeg is.
|
|
singleton
|
Geeft het enige
aanwezige element dat in de verzameling zit naar buiten. Indien er
meerdere elementen zijn wordt een runtime-error gecreëerd.
|
|
%replace old
new
|
Deze operatie
verandert het object old naar new
waarbij de grenzen niet worden aangepast. Vandaar het %-teken.
|
|
recalc-bounds
|
Na een reeks %replace-operaties dient deze functie eens aangeroepen te
worden zodat de x/y-intervallen weer goed staan.
|
|
info
|
Vraagt de info van
de graph-set op.
|
|
set-info!
|
Verandert de info
van de graph-set. Het info-field speelt totaal geen rol bij het gedrag
van de verzameling.
|
|
foreach func
|
Past, indien
gevraagd, op elk element func toe. Er wordt #f
weergegeven als de functie voortijdig gestopt werd. #t in het andere
geval. Func moet voldoen aan volgende voorwaarden :
hij moet 1 parameter (een grafisch object) verwachten en moet altijd
als resultaat een 'stop of een 'gadoor
naar buiten werpen. Tijdens het verloop van een foreach kan de
verzameling door de gebruiker van het ADT gerust gewijzigd worden
(elementen toevoegen, weglaten)
|
|
copy
|
Copieert het
volledige adt. Hierbij worden de deel-objecten niet gecopieerd. (dit is
ook niet nodig omdat de enig mogelijke objecten volledig functioneel
worden aangesproken)
|
|
add!
|
Voegt een element
toe aan de verzameling. De bounds staan nadien vanzelf weer goed.
|
In : grafische objecten pi
Out : graph-set r
Comments : r
bevat al de meegegeven objecten. Een voorbeeld van een aanroep :
(graph-set
(make-point 0 0) (make-point 10 20))
(define graph-set
(lambda object-list
(make-graph-set object-list)))
In : list object-list
Out : graph-set r
Comments : Deze procedure maakt een open grafische
verzameling waarbij al de objecten onafhankelijk van mekaar worden in
acht
genomen. (behalve de operatie punt-in?)
(define (make-graph-set object-list)
(let ((info #f)
(xmin
#f)
(ymin
#f)
(xmax
#f)
(ymax
#f))
In : something w
Out : something info
Comments : Verandert de info van de
graph-set. Het info-field speelt totaal geen rol bij het gedrag van de
verzameling. Als resultaat wordt de nieuwe info
naar buiten gesmeten.
(define (set-info!
w)
(set! info w))
In : go wat
Out : nothing
Comments : Voegt een element toe aan de verzameling. De
bounds staan nadien vanzelf
weer goed. Als wat=#f dan wordt er
niets toegevoegd.
(define (add! wat)
(if wat
(begin
(set!
object-list (cons wat
object-list))
(add-grensum
wat))))
In : function action
Out : bool result
Comments : Past, indien gevraagd, op elk element func toe. Er wordt #f weergegeven als de functie
voortijdig gestopt
werd. #t in het andere geval. Func moet
voldoen aan volgende voorwaarden : hij moet 1 parameter (een grafisch
object)
verwachten en moet altijd als resultaat een 'stop
of een 'gadoor naar buiten werpen.
Tijdens het verloop van een foreach kan de verzameling door de
gebruiker van
het ADT gerust gewijzigd worden (elementen toevoegen, weglaten)
(define (foreach
action)
(define (loop l)
(if
(null? l)
#t ;ze zijn allemaal gedaan
(let ((return (action (car
l))))
(cond ((eq? return
'gadoor) (loop (cdr l)))
((eq? return 'stop)
#f) ;voortijdig gestopt
(else (error
"graph-set-foreach : " return))))))
(loop
object-list))
In : nothing
Out : bool b
Comments : Geeft #t weer indien self leeg
is.
(define (empty?)
(null?
object-list))
In : nothing
Out : go result
Comments : Geeft het enig aanwezige element dat in de
verzameling zit naar buiten.
Indien er meerdere elementen zijn wordt een runtime-error gecreëerd.
(define
(singleton)
(if (null?
object-list)
(error
"Graph-set empty,
singleton")
(if
(pair? (cdr object-list))
(error "More than 1
element, singleton")
(car object-list))))
In : nothing
Out : nothing
Comments : print self af onder de vorm
"{go1,go2,...gon}"
(define
(display-graph-set)
(define (iter l)
(if
(null? l) #t
(begin
((car l) 'display)
(if (pair? (cdr l))
(message " , "))
(iter (cdr l)))))
(message "{")
(iter object-list)
(message "}"))
In : Nothing
Out : Nothing
Comments : tekent self op het scherm.
Indien color 'ownstyle is wordt elk
object apart getekend met zijn eigen standaardkleur.
(define
(show-graph-set color)
(foreach (lambda
(o) ((o 'show)
color) 'gadoor)))
In : real horizon
Out : list nlpntn
Comments : Geeft als resultaat een gesorteerde lijst naar
buiten van nulpunten.
Deze operatie is nodig om nadien te kunnen controleren of een punt in
een
gesloten kromme valt.
(define
(nulpunten@horizon horizon)
;geeft als
resultaat een
gesorteerde lijst weer van punten die
;op de horizon
liggen
(let ((result
(list 'prefix)))
(define
(add-nulpunt nlpnt)
(let
((np1 (nulpunt-pos nlpnt)))
(define (iter prev cur)
(cond ((null? cur)
(set-cdr! prev (list nlpnt)))
((< (nulpunt-pos
(car cur)) np1)
(iter cur (cdr
cur)))
((= (nulpunt-pos
(car cur)) np1)
(set-car! cur
(merge-nulpunten (car cur) nlpnt)))
(else
(set-cdr! prev
(cons nlpnt cur)))))
(iter result (cdr result))
#f))
(define
(add-nulpunten
nlpnt-lst)
(for-each
(lambda (nlpnt)
(add-nulpunt nlpnt)) nlpnt-lst))
(foreach
(lambda
(go)
(add-nulpunten ((go
'nulpunten@horizon) horizon))
'gadoor))
(cdr
result)))
In : real waar, bool gebied-nu,
int pos-count, int neg-count,
list nlpntn
Out : bool result
Comments : result geeft weer of de
positie waar, positief/negatief is
door rekening te houden met de nlpntn-list.
Normaal gebruik van deze functie is als volgt : (%positief-gebied waar #f
0 0 nulpunten). Voor de rest is dit een interne functie die niet
toegankelijk is van buiten uit. (%)
(define (%positief-gebied?
waar
gebied-nu
pos-count neg-count
next-nulpunt)
(if (null?
next-nulpunt)
gebied-nu
(let ((nulpunt (car
next-nulpunt)))
(if (> (nulpunt-pos
nulpunt) waar)
gebied-nu
(begin
(set! pos-count (+
(positiviteit nulpunt) pos-count))
(set! neg-count (+
(negativiteit nulpunt) neg-count))
(set! pos-count (if
(= (remainder pos-count 2) 1) 1 0))
(set! neg-count (if
(= (remainder neg-count 2) 1) 1 0))
(if (and (= pos-count
1) (= neg-count 1))
(%positief-gebied?
waar (not gebied-nu) 0 0 (cdr
next-nulpunt))
(%positief-gebied?
waar gebied-nu pos-count neg-count
(cdr
next-nulpunt))))))))
In : point p
Out : bool r
Comments : geeft #t weer indien p op self
ligt
(define (punt-op?
p)
(not (foreach
(lambda (go)
(if ((go 'punt-op?)
p)
'stop
'gadoor)))))
In : point p
Out : bool r
Comments : Geeft weer of punt p in de
grafische verzameling valt, of niet. Dit is nuttig als er een gesloten
vlak
wordt gecreëerd met lijnen.
(define (punt-in? p)
(if (punt-op? p)
#t
(let*
((nulpunten
(nulpunten@horizon (p 'y))))
(%positief-gebied? (p 'x) #f
0 0 nulpunten))))
In : nothing
Out : interval r
Comments : het geretourneerde interval r
geeft de projectie van de lijn op de X-as weer.
(define (x-int)
(make-interval
xmin xmax))
In : nothing
Out : interval r
Comments : het geretourneerde interval r
geeft de projectie van de lijn op de Y-as weer.
(define (y-int)
(make-interval
ymin ymax))
In : go obj
Out : Nothing
Comments : Past de huidige grenzen aan aan de grenzen van obj. Zodat het x-int
& y-int van self valid blijft.
(define
(add-grensum obj)
(let ((xint (obj
'x-int))
(yint (obj 'y-int)))
(if
(not xmin)
(begin
(set! xmin (from-grens
xint))
(set! xmax (to-grens
xint))
(set! ymin (from-grens
yint))
(set! ymax (to-grens
yint)))
(begin
(if (> xmin (from-grens
xint)) (set! xmin (from-grens xint)))
(if (> ymin (from-grens
yint)) (set! ymin (from-grens yint)))
(if (< xmax (to-grens
xint)) (set! xmax (to-grens xint)))
(if (< ymax (to-grens
yint)) (set! ymax (to-grens yint)))))))
In : point vct
Out : list r
Comments : r is het resultaat na self te verplaatsen over een afstand vct. Er
wordt gewoon een lijst van
verplaatste objecten naar buiten gegeven. Vandaar het %-teken.
(define
(%translate vct)
(let
((result-list '()))
(foreach
(lambda
(go)
(set! result-list (cons ((go
'translate) vct) result-list))
'gadoor))
result-list))
In : point around, angle angle
Out : list r
Comments : r is het beeld van self
door de rotatie-operatie met
fixpunt around en hoek angle. Er
wordt een lijst van gedraaide
objecten naar buiten gegeven.
(define (%rotate
center angle)
(let
((result-list '()))
(foreach
(lambda
(go)
(set! result-list (cons
((go 'rotate) center
angle) result-list))
'gadoor))
result-list))
In : point around, angle angle
Out : graph-set r
Comments : r is het beeld van self
door de rotatie-operatie met
fixpunt around en hoek angle. Er
wordt een nieuwe graph-set
gemaakt.
(define (rotate
center angle)
(make-graph-set
(%rotate center angle)))
In : point vct
Out : graph-set r
Comments : r is het resultaat na self te verplaatsen over een afstand vct. Er
wordt een nieuwe graph-set
gemaakt.
(define (translate
vct)
(make-graph-set
(%translate vct)))
In : point howmuch
Out : list r
Comments : r is het lijnstuk dat ontstaat
door self te verplaatsen over de
afstand howmuch. Er wordt een lijst
van gesleepte objecten naar buiten gegeven.
(define
(%translate-sleep howmuch)
(let
((result-list '()))
(foreach
(lambda
(go)
(set! result-list (cons
((go 'translate-sleep)
howmuch) result-list))
'gadoor))
result-list))
In : point howmuch
Out : graph-set r
Comments : r is het lijnstuk dat ontstaat
door self te verplaatsen over de
afstand howmuch. Er wordt een nieuwe
grafische verzameling naar buiten gegeven.
(define
(translate-sleep howmuch)
(make-graph-set
(%translate-sleep
howmuch)))
In : Nothing
Out : Nothing
Comments : Na een reeks %replace-operaties
dient deze functie eens aangeroepen te worden zodat de x/y-intervallen
weer
goed staan.
(define
(recalc-bounds)
(set! xmin #f)
(set! xmax #f)
(set! ymin #f)
(set! ymax #f)
(foreach (lambda
(obj) (add-grensum
obj) 'gadoor)))
In : go old, go new
Out : Nothing
Comments : Deze operatie verandert het object old
naar new waarbij de grenzen niet
worden aangepast. Vandaar het %-teken.
(define (%replace!
old new)
(define (loop cur)
(cond
((null? cur) (error
"10 m/s2"))
((eq? (car cur) old)
(set-car! cur new))
(else (loop (cdr cur)))))
(loop object-list)
#t)
In : nothing
Out : graph-set result
Comments : Copieert het volledige adt. Hierbij worden de
deel-objecten niet
gecopieerd. (dit is ook niet nodig omdat de enig mogelijke objecten
volledig
functioneel worden aangesproken)
(define (xcopy)
(make-graph-set
(copy
object-list)))
(define (graph-set-self m)
(cond ((eq? m 'display)
(display-graph-set))
((eq? m 'punt-in?) punt-in?)
((eq? m 'punt-op?) punt-op?)
((eq?
m 'empty?) (empty?))
((eq? m 'singleton)
(singleton))
((eq? m 'nulpunten@horizon)
nulpunten@horizon)
((eq?
m 'add!) add!)
((eq? m '%replace!)
%replace!)
;het %-teken duid aan dat na
deze operatie de x-int en y-int
;mogelijk fout staan
((eq? m 'type-number)
graph-set-id)
((eq? m 'recalc-bounds)
(recalc-bounds))
((eq? m 'show)
show-graph-set)
((eq? m 'info) info)
((eq? m 'foreach) foreach)
((eq? m 'x-int) (x-int))
((eq? m 'y-int) (y-int))
((eq? m 'set-info!)
set-info!)
((eq? m 'translate)
translate)
((eq? m 'rotate) rotate)
((eq? m '%translate)
%translate)
((eq? m '%rotate) %rotate)
((eq? m 'translate-sleep)
translate-sleep)
((eq? m 'copy) (xcopy))
((eq? m 'type) 'graph-set)
(else (error "unkown
message - graph-set" m))))
Initialisatie van de graph-set. De bounds worden natuurlijk
eerst berekend.
(recalc-bounds)
graph-set-self))
In : something o
Out : bool b
Comments : identificeert o. Geeft #t weer
indien het een graph-set is.
(define (graph-set? o)
(eq? (o 'type-number) graph-set-id))
In : graph-set graphset, go something
Out : bool result
Comments : Geeft #t weer indien graphset
ergens snijdt met something.
(define (%intersect?-gs-something
graphset
something)
(not
((graphset 'foreach)
(lambda (graphset-deel)
(if
(intersect? something
graphset-deel)
'stop
'gadoor)))))
In : graph-set gs, line l
Out : bool result
Comments : Geeft weer of gs snijdt met l.
(define (intersect?-gs-l gs l)
(%intersect?-gs-something gs l))
In : graph-set gs1,
graph-set gs2
Out : bool result
Comments : Geeft weer of gs1 snijdt met gs2. Hierbij is mutuele recursie
mogelijk.
(define (intersect?-gs-gs gs1 gs2)
(%intersect?-gs-something gs1 gs2))
Gesloten
grafische verzamelingen
In : grafische objecten pi
Out : closed-graph-set r
Comments : r
bevat al de meegegeven objecten. Een
voorbeeld van een
aanroep :
(closed-graph-set
(make-line (make-point 0 0)
(make-point 0 20))
(make-line (make-point 0 20) (make-point 10
0))
(make-line (make-point 10 0) (make-point 0
20)))
(define closed-graph-set
(lambda object-list
(make-closed-graph-set
object-list)))
In : list object-list
Out : closed-graph-set r
Comments : Deze procedure maakt een gesloten grafische
verzameling. In feite is dit een open grafische verzameling waarbij de
punt-op?
geherdefiniëerd is.
(define (make-closed-graph-set
object-list)
(define under-gs (make-graph-set
object-list))
In : point around, angle angle
Out : closed-graph-set r
Comments : r is het beeld van self
door de rotatie-operatie met
fixpunt around en hoek angle. Een
nieuwe gesloten grafische
verzameling wordt aangemaakt.
(define (rotate
center angle)
(make-closed-graph-set
((under-gs '%rotate)
center angle)))
In : point vct
Out : point r
Comments : r is het resultaat na self te verplaatsen over een afstand vct. Hierbij
wordt een nieuwe gesloten
graph-set geprepareerd.
(define (translate
vct)
(make-closed-graph-set
((under-gs
'%translate) vct)))
In : point howmuch
Out : closed-graph-set r
Comments : r is het lijnstuk dat ontstaat
door self te verplaatsen over de
afstand howmuch. Er wordt een nieuwe closed-graph-set
naar buiten gegeven.
(define
(translate-sleep howmuch)
(closed-graph-set
closed-graph-set-self
(translate
howmuch)
((under-gs
'translate-sleep)
howmuch)))
Dispatcher closed-graph-set-self.
Initialisatie door het naar buiten geven van self.
(define
(closed-graph-set-self m)
(cond ((eq? m 'type-number)
closed-graph-set-id)
((eq?
m 'punt-op?) (under-gs
'punt-in?))
((eq?
m 'translate) translate)
((eq?
m 'rotate) rotate)
((eq?
m 'translate-sleep)
translate-sleep)
(else
(under-gs m))))
closed-graph-set-self)
In : something o
Out : bool b
Comments : identificeert o. Geeft #t weer
indien het een closed-graph-set is.
(define (closed-graph-set? o)
(eq? (o 'type-number)
closed-graph-set-id))
In : list points
Out : closed-graph-set result
Comments : Geeft een gesloten verzameling naar buiten die
bestaan uit de
verbindingslijnen tussen de meegegeven punten points.
Bijvoorbeeld
(%make-L-vlak
(list
(make-point 0 0)
(make-point 0 20)
(make-point 10 0)))
is equivalent met
(closed-graph-set
(make-line (make-point 0 0)
(make-point 0 20))
(make-line (make-point 0 20) (make-point 10
0))
(make-line (make-point 10 0) (make-point 0
20)))
(define (%make-L-vlak punten-lijst)
(let ((result (closed-graph-set)))
(define (iter prev cur)
(cond ((null? cur)
((result 'add!) (make-line
(car punten-lijst) prev))
result)
(else
((result 'add!) (make-line
prev (car cur)))
(iter (car cur) (cdr
cur)))))
(iter (car punten-lijst) (cdr
punten-lijst))))
In : point p1,
point p2,point
p3
Out : closed-graph-set result
Comments : Deze is een eenvoudige definitie om gesloten
vlakken te maken. Voorbeeld :
(%make-L-vlak
(list
(make-point 0 0)
(make-point 0 20)
(make-point 10 0)))
wordt :
(make-L-vlak
(make-point 0 0)
(make-point 0 20)
(make-point 10 0))
(define make-L-vlak
(lambda punten-lijst
(%make-L-vlak punten-lijst)))
In : closed-graph-set cgs, go
other
Out : bool result
Comments : Geeft #t weer indien other
snijdt met cgs
(define (%intersect-cgs-other cgs
other)
(not
((cgs 'foreach)
(lambda
(splitsing)
(if
(intersect? other splitsing)
'stop
'gadoor)))))
In : closed-graph-set cgs,
line l
Out : bool result
Comments : Geeft #t weer als l ergen op cgs valt.
(define (intersect?-cgs-l cgs l)
(or (%intersect-cgs-other cgs l)
((cgs 'punt-op?) (l 'from-p))
((cgs 'punt-op?) (l 'to-p))))
In : closed-graph-set a,
closed-graph-set b
Out : bool result
Comments : Geeft weer of a snijdt met b. Dit is
een vreemd stukje code omdat de bewerkging %intersect-cgs-other
niet commutatief is als other ook een
closed-graph-set is. Neem bijvoorbeeld
Het resultaat van
(%intersect-cgs-other a b) is hier #t, maar
het resultaat van (%intersect-cgs-other b a) is #f.
(define (intersect?-cgs-cgs a b)
(or (%intersect-cgs-other a b)
(%intersect-cgs-other b a)))
In : closed-graph-set cgs,
graph-set gs
Out : bool result
Comments : Result
is #f als cgs niet snijdt met gs.
(define (intersect?-cgs-gs cgs gs)
(%intersect-cgs-other cgs gs))
Intersecties
In : go a, go b
Out : bool result
Comments : Geeft weer of a op één of
andere manier snijdt met b. Eerst
worden a en b gesorteerd volgens
type-number. Nadien wordt gecontroleerd of het
kanshebbers zijn om te snijden en uiteindelijk wordt de werkelijke
snijd-routine aangeroepen.
(define (intersect? a b)
(cond ((> (b 'type-number) (a
'type-number)) (intersect? b a))
((not
(intersect-interval (a
'x-int) (b 'x-int))) #f)
((not
(intersect-interval (a
'y-int) (b 'y-int))) #f)
((point?
a) (intersect?-p-p a
b))
((line?
a)
(cond
((point? b)
(intersect?-l-p a b))
((line? b)
(intersect?-l-l a b))
(else (error
"intersect line-?"))))
((circle?
a)
(cond
((point? b)
(intersect?-c-p a b))
((line? b)
(intersect?-c-l a b))
((circle? b)
(intersect?-c-c a b))
(else (error
"intersect circle-?"))))
((graph-set?
a)
(cond
((point? b)
(intersect?-gs-p a b))
((line? b)
(intersect?-gs-l a b))
((circle? b)
(intersect?-gs-c a b))
((graph-set? b)
(intersect?-gs-gs a b))
(else (error "intersect
graph-set-?"))))
((closed-graph-set?
a)
(cond
((point? b)
(intersect?-cgs-p a b))
((line? b)
(intersect?-cgs-l a b))
((circle? b)
(intersect?-cgs-c a b))
((graph-set? b)
(intersect?-cgs-gs a b))
((closed-graph-set? b)
(intersect?-cgs-cgs a b))
(else (error
"intersect closed-graph-set-?"))))))
De Werelden
Set's
|
Set
|
|
name & parameters
|
action
|
|
add who
|
Voegt who
toe aan de verzameling. Indien men in een foreach
zit zal het nieuwe element niet meer bekeken worden.
|
|
add-set! other-set
|
Voegt een nieuwe
verzameling toe aan self. Indien
men met een foreach bezig is zal func
ook nog eens worden aangeroepen voor de nieuwe elementen.
|
|
delete! who
|
Verwijdert een
element uit de verzameling. Dit levert geen problemen in de foreach.
|
|
empty?
|
Geeft weer of de
verzameling leeg is.
|
|
replace! old
new
|
Vervangt old door new. Het nieuwe element wordt
niet meer behandeld in een foreach.
|
|
list
|
Geeft een
lijst-representatie van de verzameling naar buiten.
|
|
present? who
|
Controleert of who aanwezig is in de verzameling.
|
|
foreach
|
Past, indien
gevraagd, op elk element func toe. Er wordt #f
weergegeven als de functie voortijdig gestopt werd. #t in het andere
geval. Func moet voldoen aan volgende voorwaarden :
hij moet 1 parameter (een element van de verzameling) verwachten en
moet altijd als resultaat een 'stop of een 'gadoor
naar buiten werpen. Tijdens het verloop van een foreach
kan de verzameling door de gebruiker van het ADT gerust gewijzigd
worden (elementen toevoegen, weglaten...).
|
In : list contents
Out : set result
Comments : contents
is de lijst van objecten die initiëel aanwezig zijn.
(define (make-set contents)
In : something who
Out : bool result
Comments : Verwijdert who uit de lijst.
Merk op dat hiervoor speciaal een prefix wordt gemaakt.
(define (delete who)
(define (loop prev cur)
(cond ((null?
cur) #t)
((eq? (car cur) who)
(set-cdr! prev (cdr cur))
(loop prev (cdr cur)))
(else
(loop cur (cdr cur)))))
(let ((prefix (cons 'prefix
contents)))
(loop prefix
contents)
(set! contents
(cdr prefix))
#t))
In : something who
Out : bool result
Comments : Voegt who toe aan het begin
van de verzameling (voor zover een verzameling geordent is natuurlijk)
(define (add who)
(set! contents (cons who
contents))
#t)
In : function action
Out : bool result
Comments : Past, indien gevraagd, op elk element func toe. Er wordt #f weergegeven als de functie
voortijdig gestopt
werd. #t in het andere geval. Func moet
voldoen aan volgende voorwaarden : hij moet 1 parameter (een element
van de
verzameling) verwachten en moet altijd als resultaat een 'stop
of een 'gadoor naar
buiten werpen. Tijdens het verloop van een foreach kan de verzameling
door de
gebruiker van het ADT gerust gewijzigd worden (elementen toevoegen,
weglaten...).
(define
(foreach action)
(define (loop l)
(if (null? l)
#t
;ze zijn allemaal gedaan
(let
((return (action (car
l))))
(cond ((eq? return 'gadoor)
(loop (cdr l)))
((eq? return 'stop)
#f) ;voortijdig gestopt
(else
(error
"foreach-action geeft geeft weer : " return))))))
(loop contents))
In : something old, something new
Out : bool result
Comments : Verandert het oude object door het nieuwe.
(define (replace!
old new)
(define (loop prev cur)
(cond ((null?
cur) (error
"Nothing to replace"))
((eq? (car cur) old)
(set-cdr! prev (cons new (cdr
cur))))
(else (loop cur (cdr
cur)))))
(let ((prefix (cons 'prefix
contents)))
(loop prefix
contents)
(set! contents
(cdr prefix))
#t))
In : something who
Out : bool result
Comments : Zoekt op of who aanwezig is.
(define (present?
who)
(not
(foreach
(lambda
(item)
(if
(eq? item who)
'stop
'gadoor)))))
In : set from
Out : bool result
Comments : Transformeert self naar de
unie van self en from.
(define (add-set!
from)
(set! contents (append
contents
(from 'list))))
(define
(adt-set m)
(cond ((eq? m 'add!) add)
((eq?
m 'add-set!) add-set!)
((eq?
m 'delete!) delete)
((eq?
m 'foreach) foreach)
((eq?
m 'empty?) (null?
contents))
((eq?
m 'replace!) replace!)
((eq?
m 'list) contents)
((eq?
m 'present?) present?)
(else
(error "unkown
message - ADT-SET" m))))
adt-set)
In : something obj1,
something obj2, something obj3
...
Out : set result
Comments : Deze procedure is een handigheidje voor de
programmeur. Nu kan ik
(fast-set 1 2 3) schrijven in plaats van (make-set (list 1 2 3))
(fast-set) maakt een
lege verzameling.
(define fast-set
(lambda obj-lst
(make-set obj-lst)))
The
untouchable world
Zoals u
waarschijnlijk al is opgevallen kunnen er van dit object niet meer dan
één
instance voorkomen.
(define untouchable-world
(let ((contents (make-set '())))
In : Nothing
Out : Nothing
Comments : Ledigt de volledige wereld.
(define
(init-world)
(set! contents
(make-set '())))
In : Nothing
Out : Nothing
Comments : Hertekent elk object in zijn eigen specifieke
kleur. (deze kleur werd
meegegeven bij add!)
(define (redraw)
((contents
'foreach)
(lambda
(draw-color)
(((car
draw-color) 'show) (cdr
draw-color))
'gadoor)))
In : go drawing, color color
Out : Nothing
Comments : Zorgt dat het meegegeven object toegevoegd wordt
aan de onschendbare
wereld. Het nieuwe object zal steeds in kleur color
getekend worden.
(define (add!
drawing color)
((contents 'add!)
(cons drawing
color)))
(lambda (m)
(cond ((eq? m
'redraw) (redraw))
((eq? m 'add!) add!)
((eq? m 'init) (init-world))
(else (error
"Untouchable world -- " m))))))
The
global world
Net zoals bij
"the untouchable world" kan ook hier maar één instance van de wereld
bestaan. Als geheugenopfrissertje : een wereld is een verzameling
subwerelden.
(define world
(let ((contents (make-set '())))
In : Nothing
Out : Nothing
Comments : Herinitializeert de wereld door al de
subwerelden de vernielen.
(define
(init-world)
(set! contents
(make-set '())))
In : subworld with, set of
components exclude
of : graph-set with,
set of components exclude
Out : bool result
Comments : Geeft #t weer indien with
ergens met de globale wereld snijdt.
(define
(disturbs-with? with exclude)
(if (eq? (with
'type) 'sub-world)
(set!
with (subworld->graphset
with)))
(not
((contents
'foreach)
(lambda
(subworld)
(if ((subworld
'disturbs-with?) with exclude)
'stop
'gadoor)))))
In : color color
Out : Nothing
Comments : Hertekent de volledige wereld. Alles in kleur color. (Color mag 'ownstyle
zijn)
(define (redraw
color)
((contents
'foreach)
(lambda
(subworld)
((subworld
'redraw) color)
'gadoor)))
In : subworld which-sub-world
Out : Nothing
Comments : Voegt de meegegeven subwereld toe aan de globale
wereld. Hierbij wordt
geen controle uitgeoefend op het al dan niet snijden met andere
subworlds.
(define (register
which-sub-world)
((contents 'add!)
which-sub-world))
In : subworld which-sub-world
Out : Nothing
Comments : Verwijdert de subwereld uit de globale wereld.
(define
(unregister which-sub-world)
((contents
'delete!)
which-sub-world))
(lambda (m)
(cond ((eq? m
'disturbs-with?)
disturbs-with?)
((eq? m 'redraw) redraw)
((eq? m 'register) register)
((eq? m 'unregister)
unregister)
((eq? m 'init) (init-world))
(else (error "World --
" m))))))
The
sub-worlds
In : Nothing
of : set optionalinit
Out : subworld result
Comments : Creëert een subwereld die geïnitialiseerd is met
optionalinit. Bij de creatie wordt
niet gecontroleerd of het wel een geldige wereld is.
(define (make-subworld .
optionalinit)
(let ((contents #f))
In : graph-set with, set of
components kill-set
Out : bool result
Comments
: Controleert of with
snijd met self. De
tekeningen die behoren tot een
component aanwezig in kill-set worden
zelf niet bekeken.
(define (disturbs-with? with kill-set)
;kill-list is een
set van
componenten (en dus niet van drawings)
;een drawing die
hoort bij een
component in de verzameling wordt
;overgeslagen
(not
((contents
'foreach)
(lambda
(robot-drawing)
(if ((kill-set 'present?) (robot-drawing
'info))
'gadoor
(if (intersect?
robot-drawing with)
'stop
'gadoor))))))
In : Nothing
Out : bool result
Comments : Geeft #t weer als de wereld gestoord is.
Hiervoor moet elke component een geldige always-connected-to
weergeven.
(define
(disturbed?)
(not
((contents
'foreach)
(lambda
(robot-drawing)
(let ((robot (robot-drawing
'info)))
(if (disturbs-with?
robot-drawing
(robot
'always-connected-to))
'stop
'gadoor))))))
In : component who, go drawing
Out : Nothing
Comments : Registreert de nieuwe component in de subwereld
waarbij het info-field van de drawing op who
wordt gezet, zodat nadien van elke drawing onmiddelijk gezegd kan
worden tot
welke component hij hoort.
(define (sign-in
who drawing)
((drawing
'set-info!) who)
((contents 'add!)
drawing))
In : color color
Out : Nothing
Comments : Hertekent de subwereld in kleur color.
Color mag opnieuw 'ownstyle
zijn.
(define (redraw
color)
((contents 'show)
color))
In : go old, go new
Out : Nothing
Comments : Vervangt de oude tekening door de nieuwe. De
nieuwe tekening krijgt dezelfde info als de oude. Na het veranderen van
deze
tekening zijn de grenzen (x-int, y-int) niet
aangepast. (%)
(define (%replace-drawing! old new)
((contents
'%replace!) old new)
((new 'set-info!)
(old 'info)))
In : Nothing
Out : Nothing
Comments : Deze routine verplicht al de componenten die hij
kent zichzelf te aanvaarden als DE subwereld. Dit is in feite het
actief maken
van een denkbeeldige subwereld.
(define
(wring-er-tussen)
((contents
'foreach)
(lambda
(robot-drawing)
(let
((robot (robot-drawing
'info)))
(if (not robot)
(begin
((robot-drawing 'show)
'white)
(error "AAAAARG,
i'm trying 9.81")))
((robot 'set-sub-world!)
subworld-self)
((robot 'set-drawing!) robot-drawing)
'gadoor)))
((world
'register) subworld-self))
In : point vct
Out : subworld r
Comments : r is het resultaat na self te verplaatsen over een afstand vct.
Hierbij worden de info-fields van
de oude subworld gecopiëerd naar de nieuwe.
(define (translate
speed)
(let
((result-graph-set
(graph-set)))
((contents
'foreach)
(lambda
(before)
(let ((after ((before
'translate) speed)))
((after 'set-info!) (before
'info))
((result-graph-set 'add!)
after))
'gadoor))
(make-subworld
result-graph-set)))
In : point howmuch
Out : graph-set r
Comments : r is het lijnstuk dat ontstaat
door self te verplaatsen over de
afstand howmuch. Er wordt hier geen
subwereld naar buiten gegeven maar wel een grafische (open) verzameling.
(define
(translate-sleep speed)
((contents
'translate-sleep)
speed))
In : noting
Out : subworld other
Comments : other is
een nieuwe subwereld waarbij al de tekeningen overgenomen zijn. De
tekeningen
zelf zijn niet gedupliceerd.
(define (copy)
(make-subworld
(contents 'copy)))
(define (subworld-self m)
(cond ((eq? m
'sign-in) sign-in)
((eq? m 'disturbs-with?)
disturbs-with?)
((eq? m 'redraw) redraw)
((eq? m 'type) 'sub-world)
((eq? m 'wring-er-tussen)
(wring-er-tussen))
((eq? m 'full-drawing)
contents)
((eq? m 'recalc-bounds)
(contents 'recalc-bounds))
((eq? m '%replace-drawing!)
%replace-drawing!)
((eq? m 'translate)
translate)
((eq? m 'disturbed?)
(disturbed?))
((eq? m 'translate-sleep)
translate-sleep)
((eq? m 'copy) (copy))
(else (error "Subworld
" m))))
Initialisatie waarbij een eventueel zelf gekozen graph-set
wordt aanvaard als contents.
(if optionalinit
(begin
(set!
contents (car
optionalinit))
(set!
optionalinit #f))
(set!
contents (graph-set)))
subworld-self))
In : subworld who
Out : graph-set result
Comments : Converteert een subwereld naar zijn bijhorende
graph-set.
(define (subworld->graphset who)
(who 'full-drawing))
De robots en de componenten
Robot-drawings
Ik heb al de
tekeningen van de robots bijeen gebracht zodat ze gemakkelijk aan te
passen
zijn. Als ik bijvoorbeeld in een snellere omgeving met meer geheugen
werk kan
ik zorgen dat de armen en de scharnierer fijner worden getekend.
Ik heb de
tekeningen bewust buiten de ADT's gebracht omdat zo een scheiding
ontstaat
tussen code en data. De tekeningen zouden nu kunnen aangepast worden
vanuit de
programma's.
Wat als de
gebruiker wil dat elke component een eigen tekening heeft ?
Verander
al de drawing@'s zodat ze een request
om een tekening naar de databank sturen.
Verander
deze robot-drawings door een databank van tekeningen/procedures.
of de meer voor de hand liggende oplossing :
Mix
bovenstaande databank tussen de component-adt's. Zodat drawing@
direct weet wat weergegeven moet worden. (persoonlijk vind
ik dat hier de abstractie een beetje verloren loopt)
In : nothing
Out : closed-graph-set result
Comments
:
result=
(define (robot-drawing)
(make-L-vlak
(make-point 20 0)
(make-point -20 0)
(make-point -14 -10)
(make-point 14 -10)))
In : real lengte
Out : graph-set result
Comments : Vraagt een arm van lengte l op. result=
(define (arm-drawing lengte)
(make-L-vlak
(make-point 0 -5)
(make-point 0 5)
(make-point lengte 5)
(make-point lengte -5)))
In : angle angle
Out : graph-set result
Comments : Vraagt een tekening van een scharnier op. Result=
(define (scharnier-drawing angle)
(let ((mid-point (make-point 10 0)))
(make-l-vlak
(make-point 0 -5)
(make-point 0 5)
(make-point (- 10
(* 5 (sin
angle))) 5)
(realize-angle
mid-point
11.18033989 (+ angle 0.463647609))
(realize-angle
mid-point
11.18033989 (- angle 0.463647609))
(make-point (+ 10
(* 5 (sin
angle))) -5))))
Terminale
componenten (pen/boor/null)
In : function trans-func,
function rot-func, function own-dispatcher
Out : terminal result
Comments : Result is een voorgedefinieerd
armuiteinde waarbij trans-func, rot-func en
own-dispatcher op het juiste moment
worden aangeroepen. M.a.w. het gedrag van het uiteinde t.o.v. de
onschendbare
wereld kan zelf gekozen worden. Trans-func
wordt opgeroepen wanneer het uiteinde verplaatst wordt. Trans-func
verwacht 2 parameters. De
oude positie en de verplaatsingsvector.
Rot-func verwacht 3 parameters : de
oude positie, het centrum van de draaiing en de hoek waarover gedraaid
wordt.
Own-dispatcher wordt aangeroepen als
er een bericht binnenkomt dat door de terminal niet verstaan wordt.
(define (create-terminal trans-func
rot-func
own-dispatcher)
(let ((old-pos #f)
(last-angle
#f)
(drawing
(graph-set)))
In : color color
Out : nothing
Comments : Dit is één van de dummy-achtigen. Het bericht
show kan opgestuurd worden
naar een terminal, maar aangezien die geen tekening heeft moet er ook
niets
getekend worden.
(define
(show-terminal color)
#t)
In : component father
Out : bool result
Comments : Lijmt componenten aaneen zodat ze een tree
vormen. Indien father reeds
gekend was wordt #f weergegeven. (dit wil dus zeggen dat de component
reeds in
gebruik was). De glue message wordt
doorgegeven aan de kinderen. In dit geval komt dit neer op weergeven
dat al de
kinderen gelijmt zijn.
(define (glue
father)
#t)
In : sub-world sw, point pos,
angle angle
Out : nothing
Comments : Na het aaneen glue-en van de
componenten moet ook een subwereld gecreëerd worden. Dit wordt met deze
routine
gedaan. Sw is de subworld waarin het
resultaat moet komen, pos is de
positie van de component, angle is de
hoek die de component zal vormen. Hier wordt de old-pos en de hoek
gewoon
onthouden.
(define
(sign-in-world sub-world pos angle)
(set! old-pos pos)
(set! last-angle
angle)
#t)
In : graph-set result-in,
point howmuch
Out : nothing
Comments : Vraagt de component of hij het sleeppad ten
gevolge van een translate
over howmuch wil vervolledigen in result-in.
(define
(add-translate-sleeppad result-in howmuch)
result-in)
In : point naar
Out : nothing
Comments : Vertelt de component dat al de checks voor een
translatie positief waren
en dat de translatie over naar
uitgevoerd mag worden. Hierbij wordt niet verwacht dat de tekeningen en
de
subworlds ge-update worden. Deze zijn reeds veranderd. Deze routine
zorgt
gewoon dat een component zijn nieuwe positie kan bijhouden. Hier moet
daarvoor
de trans-func aangeroepen worden.
(define
(translate-action naar)
(trans-func
old-pos naar)
(set! old-pos
((old-pos
'translate) naar))
#t)
In : point around, angle angle
Out : nothing
Comments : Net zoals bij translate-action
laat dit bericht toe dat de component zijn posities en hoeken up to
date blijven.
De rot-func wordt hierbij
aangeroepen.
(define
(rotate-action rond angle)
(rot-func old-pos
rond angle)
(set! old-pos
((old-pos 'rotate)
rond angle))
(set! last-angle
(+ last-angle
angle))
#t)
In : nothing
Out : set of components result
Comments : Dit bericht vraagt de component of hij eens een
lijst wil naar buiten
geven met wie hij altijd verbonden zal zijn. Dit is om vanzelfsprekende
snijdingen op voorhand weg te filteren en zelf niet meer te
controleren. Omdat
er geen tekening bestaat van een armuiteinde wordt de lege verzameling
naar
buiten gemikt.
(define
(always-connected-to)
(fast-set))
In : subworld result-in,
point howmuch
Out : nothing
Comments : Vraagt de component of hij zichzelf eens
denkbeeldig wil verplaatsen
over afstand howmuch. Hierbij wordt
verwacht dat in result-in de oude
tekening van de component wordt vervangen door een nieuwe. Hier komt
dit neer
op : niets veranderen en result-in
weergeven.
(define
(change-translate-world! result-in translation)
result-in)
In : subworld result-in,
point around, angle howmuch
Out : nothing
Comments : Vraagt aan de component of hij zichzelf eens
denkbeeldig wil roteren
rond around bij een hoek van howmuch.
Hierbij dient de oude tekening
van de component die aanwezig is in result-in
vervangen worden door een nieuwe tekening. Ook hier komt dit neer op :
niets
veranderen en result-in weergeven.
(define
(change-rotate-world! result-in around rot)
result-in)
In : graph-set result-in,
point howmuch
Out : nothing
Comments : Vraagt de component of hij het sleeppad ten
gevolge van een translate
over howmuch wil vervolledigen in result-in.
Een tekening die niet bestaat
heeft geen sleeppad dus result-in
wordt gewoon naar buiten gegooid.
(define (add-translate-sleeppad!
result-in translation)
result-in)
(define (terminal-self m)
(cond ((eq? m
'glue) glue)
((eq? m 'unglue) #t)
((eq? m
'always-connected-to) (always-connected-to))
((eq? m 'sign-in-world)
sign-in-world)
((eq? m 'show)
show-terminal)
((eq? m 'drawing) drawing)
((eq? m 'translate-action)
translate-action)
((eq? m 'rotate-action)
rotate-action)
((eq? m 'child-list) '())
((eq? m
'change-translate-world!) change-translate-world!)
((eq? m
'change-rotate-world!) change-rotate-world!)
((eq? m
'add-translate-sleeppad!) add-translate-sleeppad!)
(else (own-dispatcher m
old-pos))))
terminal-self))
De null-component.
Deze reageert niet op translaties, rotaties en heeft geen eigen
berichten. (er
is slechts 1 null-component)
(define null-component
(create-terminal
(lambda (oldpos vect)
#t)
(lambda (oldpos around angle)
#t)
(lambda (m oldpos)
(error "unkown
message
null-component" m))))
In : color color
Out : pen-component result
Comments : Er wordt een pen gemaakt die reageert op
translaties/rotaties en een
paar eigen berichten heeft.
(define (make-pen color)
(let ((pen-down #f))
(create-terminal
(lambda (oldpos
vect)
(if
pen-down
((untouchable-world 'add!)
((oldpos 'translate-sleep)
vect)
color)))
(lambda (old-pos
rond angle)
(if
pen-down
((untouchable-world 'add!)
((old-pos 'rotate-sleep)
rond angle)
color)))
(lambda (m
old-pos)
(cond
((eq? m 'pen-up) (set!
pen-down #f))
((eq? m 'pen-down) (set!
pen-down #t))
((eq? m 'color!)
(lambda (new-color) (set!
color new-color)))
(else (error "Unkown
message pen -- " m)))))))
In : nothing
Out : boor-component result
Comments : Maakt een boor die enkel reageert op het bericht
'boor. De gaten die
geboort worden zijn altijd in magenta.
(define (make-boor)
(create-terminal
(lambda (oldpos vect)
#t)
(lambda (old-pos rond angle)
#t)
(lambda (m old-pos)
(cond ((eq? m
'boor)
((untouchable-world 'add!)
old-pos
'magenta)
((untouchable-world 'add!)
(make-circle old-pos 2 0
2PI)
'magenta)
(redraw)
)
(else (error "Unkown
message boor -- " m))))))
Arm-component
In : real min, real max, real
lengte, angle voethoek, component
child
Out : arm result
Comments
:
Bij de creatie van
de arm wordt nog niet gecontroleerd of er snijdingen zullen optreden.
Wel wordt
al gecontroleerd of de meegegeven parameters aan een paar minimumeisen
voldoen.
Namelijk : "Minimum<maximum, Lengte tussen minimum en maximum,
Minimum>10"
(define (make-arm minimum maximum
lengte
voethoek child)
(let ((parent #f)
(drawing
#f)
(last-pos
#f)
(last-angle
#f)
(sub-world
#f))
In : sub-world to
Out : nothing
Comments : Wordt opgeroepen als de sub-world van de robot
verandert. Hierbij wordt
de subworld van de component gezet op to.
(define
(set-sub-world! to)
(set! sub-world
to))
In : graph-set to
Out : nothing
Comments : Wordt opgeroepen als de sub-world van de robot
verandert. Hierbij wordt
de drawing van de component gezet op to.
(define
(set-drawing! to)
(set! drawing to))
In : component father
Out : bool result
Comments : Lijmt componenten aaneen zodat ze een tree
vormen. Indien father reeds
gekend was wordt #f weergegeven. (dit wil dus zeggen dat de component
reeds in
gebruik was). De glue message wordt
doorgegeven aan de kinderen.
(define (glue
father)
(if parent
#f
(begin
(set! parent father)
((child 'glue) arm-self))))
In : nothing
Out : nothing
Comments : Zorgt dat de vader niet meer gekend is. Deze
routine dient opgeroepen te
worden als de creatie van de robot mislukt is, zodat de componenten in
een
nieuwe robot gebruikt kunnen worden
(define (unglue)
(set! parent #f)
(child 'unglue))
In : point pos, angle angle,
real l
Out : go
Comments : De tekening van een arm wordt opgevraagd,
geroteerd en verplaatst naar
de juiste positie.
(define (drawing@
pos angle l)
(((((arm-drawing
l)
'rotate)
(make-point 0 0)
angle)
'translate)
pos))
In : real l
Out : bool result
Comments : Geeft weer of l een
aanvaardbare
lengte is voor de arm.
(define
(valid-length? l)
(and (>=
minimum 10)
(>= l minimum)
(<= l maximum)))
In : nothing
Out : bool/error result
Comments : controleert of de initiële armlengte
aanvaardbaar is. Indien niet wordt
een error naar buiten gegeven en geen boolean.
(define
(valid-init?)
(if
(valid-length? lengte)
#t
(make-error
'value
"Impossible arm-value")))
In : point pos, angle angle
Out : point end-point
Comments : Berekent het eindpunt van de arm. Dus het
beginpunt van de child-component.
(define
(calc-end-point pos angle)
(realize-angle
pos lengte angle))
In : sub-world sw, point pos,
angle angle
Out : nothing
Comments : Na het aaneen glue-en van de
componenten moet ook een subwereld gecreëerd worden. Dit wordt met deze
routine
gedaan. Sw is de subworld waarin het
resultaat moet komen, pos is de
positie van de component, angle is de
hoek die de component zal vormen.
(define
(sign-in-world sw pos angle)
(set! last-angle
angle)
(set! last-pos
pos)
(set! drawing
(drawing@ pos angle
lengte))
((sw 'sign-in)
arm-self drawing)
((child
'sign-in-world) sw
(calc-end-point pos angle)
(+ angle
voethoek)))
In : nothing
Out : set of components result
Comments : Dit bericht vraagt de component of hij eens een
lijst wil naar buiten
geven met wie hij altijd verbonden zal zijn. Dit is om vanzelfsprekende
snijdingen op voorhand weg te filteren en zelf niet meer te controleren.
(define (always-connected-to)
(fast-set parent
arm-self child))
In : graph-set result-in,
point howmuch
Out : nothing
Comments : Vraagt de component of hij het sleeppad ten
gevolge van een translate
over howmuch wil vervolledigen in result-in.
(define
(add-translate-sleeppad! result-in howmuch)
((result-in
'add!) ((drawing
'translate-sleep) howmuch))
((child
'add-translate-sleeppad!)
result-in howmuch))
In : point naar
Out : nothing
Comments : Vertelt de component dat al de checks voor een
translatie positief waren
en dat de translatie over naar
uitgevoerd mag worden. Hierbij wordt niet verwacht dat de tekeningen en
de
subworlds ge-update worden. Deze zijn reeds veranderd. Deze routine
zorgt
gewoon dat een component zijn nieuwe positie kan bijhouden
(define
(translate-action naar)
(set! last-pos
((last-pos
'translate) naar))
((child
'translate-action) naar))
In : subworld result-in,
point howmuch
Out : nothing
Comments : Vraagt de component of hij zichzelf eens
denkbeeldig wil verplaatsen
over afstand howmuch. Hierbij wordt
verwacht dat in result-in de oude
tekening van de component wordt vervangen door een nieuwe.
(define
(change-translate-world! result-in howmuch)
((result-in
'%replace-drawing!)
drawing
((drawing
'translate) howmuch))
((child
'change-translate-world!)
result-in howmuch))
In : point around, angle angle
Out : nothing
Comments : Net zoals bij translate-action
laat dit bericht toe dat de component zijn posities en hoeken up to
date
blijven.
(define
(rotate-action around angle)
(set! last-angle
(+ last-angle
angle))
(set! last-pos
((last-pos 'rotate)
around angle))
((child
'rotate-action) around
angle))
In : subworld result-in,
point around, angle howmuch
Out : nothing
Comments : Vraagt aan de component of hij zichzelf eens
denkbeeldig wil roteren
rond around bij een hoek van howmuch.
Hierbij dient de oude tekening
van de component die aanwezig is in result-in
vervangen worden door een nieuwe tekening.
(define (change-rotate-world!
result-in around howmuch)
((result-in
'%replace-drawing!)
drawing
((drawing
'rotate) around
howmuch))
((child
'change-rotate-world!)
result-in around howmuch))
In : function get-sub-world,
function get-sleep-pad, function get-kill-set,
function act
Out : error-melding/#t
Comments :
Met de functie get-sub-world
mag de component een
voorstel doen om een nieuwe subwereld te creëren voor de robot.
Als de voorstel-subwereld intact is moet de caller een sleep-pad
opdissen zodat
gecontroleerd kan worden of dit sleeppad tegen niets onaangenaams
knalt. Indien
wel wordt een error naar buiten geworpen. Indien ook hier geen
problemen waren
mag de robot in actie treden door act
op te roepen.
Get-kill-set is hier nodig om te
weten welke componenten eigenlijk in beweging zijn. Al de
vader-componenten
bijvoorbeeld mogen niet zomaar weggegooid worden.
Van act wordt niet verwacht
dat hij ook nog de oude componenten gaat verplaatsen in de nieuwe
wereld. Deze
berekening is al eens gedaan en moet niet herdaan worden. Gewoon de
component-positions/angles moeten hierbij aangepast worden. Als act te uitvoer wordt gebracht is de
nieuwe wereld reeds actief.
Ik heb het algoritme hieronder laten staan omdat het een zeer
representatief
stuk code is voor het gehele programma.
(define (want-to-act get-sub-world
get-sleep-pad get-kill-set act)
;deze wanttoact
is verschilend van
degene die in de robot
;steekt. Hier is
een bepaalde
optimizatie verandert zodat
;hij nog steeds
juist blijft
werken...
(let
((new-sub-world (get-sub-world)))
(if
(new-sub-world 'disturbed?)
(begin
((new-sub-world 'redraw)
'red)
(make-error 'sub
"intersecting sub-world"))
(let ((sleeppad (get-sleep-pad
new-sub-world)))
(if ((world
'disturbs-with?) sleeppad (get-kill-set))
(begin
((sleeppad 'show)
'red)
((new-sub-world
'redraw) 'light-red)
(make-error 'glob
"intersecting global world"))
(begin
(if sub-world
((world 'unregister) sub-world))
(new-sub-world
'wring-er-tussen)
(act)))))))
In : real new-length
Out : error/bool result
Comments : Probeert de armlengte te wijzigen naar new-length. Indien new-length
geen geldige grootte is wordt een error weergegeven. Indien de
lengteverandering een ongewenste snijding zou veroorzaken wordt ook een
error
weergegeven.
(define
(arm-length new-length)
(if (not
(valid-length?
new-length))
(make-error
'length
"invalid length")
(let
((new-drawing (drawing@
last-pos last-angle new-length))
(translation
(realize-angle
(make-point 0 0)
(- new-length lengte)
last-angle)))
(want-to-act
(lambda
() ;get-new-sub-world
(let ((answer-world
(sub-world 'copy)))
((answer-world
'%replace-drawing!) drawing new-drawing)
((child
'change-translate-world!) answer-world translation)
(answer-world
'recalc-bounds)
answer-world))
(lambda
(new-sub)
;get-sleep-pad
(let ((answer-sleep
(graph-set new-drawing)))
((child
'add-translate-sleeppad!) answer-sleep translation)
answer-sleep))
(lambda
() ;get-kill-set
(make-set (cons parent (cons
arm-self (child 'child-list)))))
(lambda
() ;action!
(set! lengte new-length)
((child 'translate-action)
translation)
(redraw))))))
(define (arm-self m)
(cond ((eq? m
'glue) glue)
((eq? m 'unglue) (unglue))
((eq? m 'set-sub-world!)
set-sub-world!)
((eq? m 'set-drawing!)
set-drawing!)
((eq? m
'always-connected-to) (always-connected-to))
((eq? m 'sign-in-world)
sign-in-world)
((eq? m 'translate-action)
translate-action)
((eq? m 'change-translate-world!)
change-translate-world!)
((eq? m 'child-list) (cons
arm-self (child 'child-list)))
((eq? m
'add-translate-sleeppad!) add-translate-sleeppad!)
((eq? m 'rotate-action)
rotate-action)
((eq? m 'change-rotate-world!)
change-rotate-world!)
((eq? m 'arm-length)
arm-length)
(else (error "arm"
m))))
Initialisatie van de arm. Er wordt enkel gecontroleerd of de
lengtes wel aanvaardbare waarden hebben.
(let
((error-result (valid-init?)))
(if (error?
error-result)
error-result
arm-self))))
Scharnier-component
In : angle min, angle max,
angle rotation, angle voethoek,
component child
Out : scharnier result
Comments
:
Bij de creatie wordt
zoals gewoonlijk weer niet gecontroleerd of er mogelijke snijdingen
zijn, er
wordt enkel gecheckt of de meegegeven parameters wel geldig zijn.
(define (make-scharnier minimum
maximum rotation
voethoek child)
(let ((parent #f)
(drawing
#f)
(last-pos
#f)
(last-angle
#f)
(sub-world
#f))
In : sub-world to
Out : nothing
Comments : Wordt opgeroepen als de sub-world van de robot
verandert. Hierbij wordt
de subworld van de component gezet op to.
(define (set-sub-world!
to)
(set! sub-world
to))
In : graph-set to
Out : nothing
Comments : Wordt opgeroepen als de sub-world van de robot
verandert. Hierbij wordt
de drawing van de component gezet op to.
(define
(set-drawing! to)
(set! drawing to))
In : component father
Out : bool result
Comments : Lijmt componenten aaneen zodat ze een tree
vormen. Indien father reeds
gekend was wordt #f weergegeven. (dit wil dus zeggen dat de component
reeds in
gebruik was). De glue message wordt
doorgegeven aan de kinderen.
(define (glue
father)
(if parent
#f
(begin
(set! parent father)
((child 'glue)
scharnier-self))))
In : nothing
Out : nothing
Comments : Zorgt dat de vader niet meer gekend is. Deze
routine dient opgeroepen te
worden als de creatie van de robot mislukt is, zodat de componenten in
een
nieuwe robot gebruikt kunnen worden
(define (unglue)
(set! parent #f)
(child 'unglue))
In : point pos, angle angle,
angle rot
Out : go result
Comments : Er wordt een scharnier getekend op positie pos waarbij de interne hoek van het scharnier gelijk is
aan rot en de draaiingshoek in het vlak
gelijk aan angle.
(define (drawing@
pos angle rot)
(((((scharnier-drawing
rot)
'rotate)
(make-point 0 0)
angle)
'translate)
pos))
In : angle r
Out : bool res
Comments : Controleert of r wel een
geldige rotatie-hoek is voor het scharnier. Indien niet wordt
natuurlijk #f
weergegeven.
(define
(valid-rotation? r)
(and (>= r
minimum)
(<=
r maximum)))
In : nothing
Out : bool/error result
Comments : Controleert of de initiële parameters wel geldig
zijn. Er wordt een
error naar buiten geslingerd indien dit niet het geval is. Anders een
waardevolle #t.
(define
(valid-init?)
(if
(valid-rotation? rotation)
#t
(make-error
'value
"Impossible arm-value")))
In : point pos, angle angle,
angle rot
Out : point end-point
Comments : Het resultaat is het beginpunt van de volgende
component. (of het
eindpunt van deze component)
(define
(calc-end-point pos angle rot)
(realize-angle
(realize-angle
pos 10 angle)
10 (+
rot angle)))
In : sub-world sw, point pos,
angle angle
Out : nothing
Comments : Na het aaneen glue-en van de
componenten moet ook een subwereld gecreëerd worden. Dit wordt met deze
routine
gedaan. Sw is de subworld waarin het
resultaat moet komen, pos is de
positie van de component, angle is de
hoek die de component zal vormen.
(define
(sign-in-world sw pos angle)
(set! last-angle
angle)
(set! last-pos
pos)
(set! drawing
(drawing@ pos angle
rotation))
((sw 'sign-in)
scharnier-self
drawing)
((child
'sign-in-world) sw
(calc-end-point
pos angle
rotation) (+ angle voethoek rotation)))
In : nothing
Out : set of components result
Comments : Dit bericht vraagt de component of hij eens een
lijst wil naar buiten
geven met wie hij altijd verbonden zal zijn. Dit is om vanzelfsprekende
snijdingen op voorhand weg te filteren en zelf niet meer te controleren.
(define
(always-connected-to)
(fast-set parent
scharnier-self
child))
In : graph-set result-in,
point howmuch
Out : nothing
Comments : Vraagt de component of hij het sleeppad ten
gevolge van een translate
over howmuch wil vervolledigen in result-in.
(define
(add-translate-sleeppad! result-in howmuch)
((result-in
'add!) ((drawing
'translate-sleep) howmuch))
((child
'add-translate-sleeppad!)
result-in howmuch))
In : point naar
Out : nothing
Comments : Vertelt de component dat al de checks voor een
translatie positief waren
en dat de translatie over naar
uitgevoerd mag worden. Hierbij wordt niet verwacht dat de tekeningen en
de
subworlds ge-updated worden. Deze zijn reeds veranderd. Deze routine
zorgt
gewoon dat een component zijn nieuwe positie kan bijhouden
(define
(translate-action naar)
(set! last-pos
((last-pos
'translate) naar))
((child
'translate-action) naar))
In : subworld result-in,
point howmuch
Out : nothing
Comments : Vraagt de component of hij zichzelf eens
denkbeeldig wil verplaatsen
over afstand howmuch. Hierbij wordt
verwacht dat in result-in de oude
tekening van de component wordt vervangen door een nieuwe.
(define
(change-translate-world! result-in howmuch)
((result-in
'%replace-drawing!)
drawing
((drawing
'translate) howmuch))
((child
'change-translate-world!)
result-in howmuch))
In : point around, angle angle
Out : nothing
Comments : Net zoals bij translate-action
laat dit bericht toe dat de component zijn posities en hoeken up to
date
blijven.
(define
(rotate-action around angle)
(set! last-angle
(+ last-angle
angle))
(set! last-pos
((last-pos 'rotate)
around angle))
((child
'rotate-action) around
angle))
In : subworld result-in,
point around, angle howmuch
Out : nothing
Comments : Vraagt aan de component of hij zichzelf eens
denkbeeldig wil roteren
rond around bij een hoek van howmuch.
Hierbij dient de oude tekening
van de component die aanwezig is in result-in
vervangen worden door een nieuwe tekening.
(define
(change-rotate-world! result-in around howmuch)
((result-in
'%replace-drawing!)
drawing
((drawing
'rotate) around
howmuch))
((child
'change-rotate-world!)
result-in around howmuch))
In : angle new-rot
Out : Error/bool result
Comments : Beweegt het scharnier naar de nieuwe
rotatiehoek. Hierbij wordt enkel
gecontroleerd dat het wel een geldige rotatiehoek is. Er is geen
controle op de
snijdingen.
(define
(scharnier-angle new-rot)
(if (not
(valid-rotation?
new-rot))
(make-error
'ROT "invalid
angle")
(let
((new-drawing (drawing@
last-pos last-angle new-rot))
(torotate (- new-rot
rotation))
(midpoint (realize-angle
last-pos 10 last-angle)))
(define
(get-new-sub-world)
(let
((answer-world (sub-world
'copy)))
((answer-world
'%replace-drawing!) drawing new-drawing)
((child
'change-rotate-world!) answer-world midpoint torotate)
(answer-world
'recalc-bounds)
answer-world))
(define
(act)
(set!
rotation new-rot)
((child
'rotate-action)
midpoint torotate)
(redraw))
(if
sub-world ((world
'unregister) sub-world))
((get-new-sub-world)
'wring-er-tussen)
(act))))
Dispatcher
scharnier-self
(define (scharnier-self m)
(cond ((eq? m
'glue) glue)
((eq? m 'unglue) (unglue))
((eq? m 'set-sub-world!)
set-sub-world!)
((eq? m 'set-drawing!)
set-drawing!)
((eq? m
'always-connected-to) (always-connected-to))
((eq? m 'sign-in-world)
sign-in-world)
((eq? m 'translate-action)
translate-action)
((eq? m
'change-translate-world!) change-translate-world!)
((eq? m 'rotate-action)
rotate-action)
((eq? m
'change-rotate-world!) change-rotate-world!)
((eq? m 'child-list) (cons
scharnier-self (child 'child-list)))
((eq? m
'add-translate-sleeppad!) add-translate-sleeppad!)
((eq? m 'scharnier-angle)
scharnier-angle)
(else (error
"scharnier" m))))
Initialisatie van het scharnier. Enkel controle op de initiële
parameters.
(let
((error-result (valid-init?)))
(if (error?
error-result)
error-result
scharnier-self))))
De Robot-root
Dit is een stuk
rare code omdat hier bijna bij elke operatie een uitzondering gevormd
moet
worden. Deze uitzonderingen ontstaan door het feit dat dit het
beginpunt van de
robot is. Op het ogenblik dat deze gemaakt wordt moet ik een robot op
het
scherm zetten (wat bij de componenten niet gebeurt)
Een andere uitzondering geeft aanleiding tot een optimisatie : het
verplaatsen
van de robot wil gewoon zeggen dat de volledige subwereld wil
verplaatsen. Dan
moet ik niet aan elke component gaan vragen of hij mij het sleeppad
eens wil
geven.
(define (make-robot pos voethoek
comp)
(let ((drawing #f)
(sub-world
#f)
)
In : sub-world to
Out : nothing
Comments : Wordt opgeroepen als de sub-world van de robot
verandert. Hierbij wordt
de subworld van de component gezet op to.
(define
(set-sub-world! to)
(set! sub-world
to))
In : graph-set to
Out : nothing
Comments : Wordt opgeroepen als de sub-world van de robot
verandert. Hierbij wordt
de drawing van de component gezet op to.
(define
(set-drawing! to)
(set! drawing to))
In : color color
Out : nothing
Comments : Tekent de robot door gewoon de volledige
subwereld te hertekenen. Hier
wordt dus niet aan elke component gevraagd of hij zichzelf eens wil
tekenen. Color mag 'ownstyle zijn.
(define
(show-robot color)
((sub-world
'redraw) color))
In : point p
Out : graph-set result
Comments : de functie drawing@ geeft de
tekening weer die hoort bij de robot. Dit is een soort van 'private'
member.
(define (drawing@
p)
(((robot-drawing)
'translate) p))
In : nothing
Out : bool result
Comments : Lijmt componenten aaneen zodat ze een tree
vormen. Indien er ergens
lussen voorkomen wordt #f weergegeven. (dit wil dus zeggen dat de
component
reeds in gebruik was). De glue
message wordt doorgegeven aan de kinderen. Merk op dat deze glue
verschilt van de andere in het feit
dat deze geen parameter verwacht. Father
is namelijk toch #f
(define (glue)
((comp 'glue)
robot-self))
In : nothing
Out : nothing
Comments : Zorgt dat de vader niet meer gekend is. Deze
routine dient opgeroepen te
worden als de creatie van de robot mislukt is, zodat de componenten in
een
nieuwe robot gebruikt kunnen worden
(define (unglue)
(comp 'unglue))
In : nothing
Out : subworld result
Comments : deze functie vervolledigt de subwereld door er
al de tekeningen van de
componenten in te steken.
(define
(init-sub-world)
(let ((result-sub
(make-subworld)))
((comp
'sign-in-world)
result-sub pos voethoek)
(set!
drawing (drawing@ pos))
((result-sub
'sign-in)
robot-self drawing)
result-sub))
In : nothing
Out : set of components result
Comments : Dit bericht vraagt de component of hij eens een
lijst wil naar buiten
geven met wie hij altijd verbonden zal zijn. Dit is om vanzelfsprekende
snijdingen op voorhand weg te filteren en zelf niet meer te controleren.
(define
(always-connected-to)
(fast-set
robot-self comp))
In : nothing
Out : error/bool result
Comments : als deze true weergeeft, is de robot gesigned-in en
zijn al de
kinderen reeds aaneen gelijmd...
Anders wordt een passende error geprepareerd.
(define (valid-init?)
(define
(try-something)
(if
(not (glue))
(make-error 'glue
"robot-lussen")
(want-to-act
init-sub-world
(lambda (new-sub-world)
(new-sub-world 'full-drawing))
(lambda () #f))))
(let ((try-result
(try-something)))
(if
(error? try-result)
(unglue))
try-result))
In : function get-sub-world,
function get-sleep-pad, function act
Out : error-melding/#t
Comments :
Met de functie get-sub-world
mag de component een voorstel doen om een nieuwe
subwereld te creëren voor de robot.
Als de voorstel-subwereld intact is moet de caller een sleep-pad
opdissen zodat
gecontroleerd kan worden of dit sleeppad tegen niets onaangenaams
knalt. Indien
wel wordt een error naar buiten geworpen. Indien ook hier geen
problemen waren
mag de robot in actie treden door act
op te roepen.
Van act wordt niet verwacht
dat hij ook nog de oude componenten gaat verplaatsen in de nieuwe
wereld. Deze
berekening is al eens gedaan en moet niet herdaan worden. Gewoon de
component-positions/angles moeten hierbij aangepast worden. Als act te uitvoer wordt gebracht is de
nieuwe wereld reeds actief.
Ik heb het algoritme hieronder laten staan omdat het een zeer
representatief
stuk code is voor het gehele programma.
(define (want-to-act get-sub-world get-sleep-pad act)
(let
((new-sub-world (get-sub-world)))
(if
(new-sub-world 'disturbed?)
(begin
((new-sub-world 'redraw)
'red)
(make-error 'sub
"intersecting sub-world"))
(begin
(if sub-world ((world
'unregister) sub-world))
(let*
((sleeppad (get-sleep-pad new-sub-world)))
(if ((world
'disturbs-with?) sleeppad (fast-set))
(begin
(if sub-world
((world 'register) sub-world))
((sleeppad 'show)
'red)
((new-sub-world
'redraw) 'light-red)
(make-error 'glob
"intersecting global world"))
(begin
(new-sub-world
'wring-er-tussen)
(act))))))))
In : point naar
Out : nothing
Comments : Vertelt de component dat al de checks voor een
translatie
positief waren en dat de translatie over naar
uitgevoerd mag worden. Hierbij wordt niet verwacht dat de tekeningen en
de
subworlds ge-update worden. Deze zijn reeds veranderd. Deze routine
zorgt
gewoon dat een component zijn nieuwe positie kan bijhouden
(define (translate-action naar)
(set! pos ((pos
'translate) naar))
((comp
'translate-action) naar)
(redraw))
In : point speed
Out : error/bool result
Comments : Dit is de vraag die gesteld wordt als de robot zich
moet
verplaatsen. Merk op dat hier een optimisatie plaatsgrijpt doordat ik
de
volledige subwereld versleep en niet aan elke component vraag of hij
zichzelf
eens wil veranderen in een denkbeeldige wereld.
(define (translation-move speed)
(want-to-act
(lambda
() ((sub-world
'translate) speed))
(lambda
(new-sub-world)
((sub-world 'translate-sleep) speed))
(lambda
() (translate-action
speed))))
(define (robot-self m)
(cond ((eq? m
'show) show-robot)
((eq? m 'drawing) drawing)
((eq? m 'right)
translation-move)
((eq? m 'set-sub-world!)
set-sub-world!)
((eq? m 'always-connected-to)
(always-connected-to))
((eq? m 'set-drawing!)
set-drawing!)
(else (error
"robot" m))))
Initialisatie.
Hier wordt gecontroleerd of er door het
maken van
de robot geen disturbed worlds optreden. Verder wordt onderzocht of er
geen componenten
zijn die 2 keer gebruikt worden. Indien alles perfect verlopen is wordt
de
robot-self weergegeven. In het andere geval een passende error.
(let
((error-result (valid-init?)))
(if (error?
error-result)
error-result
(begin
(show-robot 14)
robot-self)))))
User interface
Transcript-window/file
Vanaf hier begint zo meer het
omgeving-afhankelijke. Het aansturen van het scherm bijvoorbeeld.
PCS-window : dit is het
trace-window onderaan
het scherm.
Initialisatie van het
trace-window. Dit wordt
gedaan door de statusline over den hoop te smijten, en de console op
maat te
brengen.
(define (init-trace-window
trace-window-size)
(full-screen)
(let* ((ysize-normaltext (+ 1 (car
(window-get-position
'console))
(car (window-get-size
'console))))
(lettergrootte
(/ (1+ maxy)
ysize-normaltext)))
(window-set-position!
trace-window
(-
ysize-normaltext
trace-window-size) 0)
(set! maxy (- maxy (* lettergrootte trace-window-size) 1))
(set-viewport '(0 . 0) (cons
maxx
maxy) #t) ;#t = clipping
(window-set-attribute!
trace-window
'text-attributes 78)
(window-clear trace-window)
(window-set-cursor!
trace-window
(-1+ trace-window-size) 0)))
Dit is de file naar waar al de
messages en
vragen worden uitgevoerd. De grafische uitvoer wordt hierin niet
opgeslagen
(define transcript-file #f)
Verandert de transcriptfile
(define (set-transcript-file
filename)
(if transcript-file (close-output-port
transcript-file))
(set! transcript-file #f)
(set! transcript-file
(open-output-file filename)))
Initialiseert de transcriptfile.
Normaal is
het de file trans.txt die wordt geopend.
(define (init-transcript-file)
(set-transcript-file
"trans.txt"))
Sluit de transcript-file.
(define (close-transcript-file)
(if transcript-file (close-output-port
transcript-file)))
De constanten gebruikt in message en message-list.
(define nl 'newline)
(define wt 'wait)
Print een lijst van berichten af.
Indien het
element van de lijst
nl is : voeg een enter tussen
wt : wacht tot de gebruiker een toets drukt
procedure
is, m.a.w : een
object. Dan wordt de display-member aangeroepen
anders :
gewoon display'n
(define (message-list l)
(cond ((null? l) #t)
((procedure?
(car l))
((car
l) 'display)
(message-list
(cdr l)))
((eq?
(car l) wt)
(press-any-key)
(message-list
(cdr l)))
((eq?
(car l) nl)
(if
transcript-file (newline
transcript-file))
(newline)
(message-list
(cdr l)))
(else
(if
transcript-file (display
(car l) transcript-file))
(display
(car l))
(message-list
(cdr l)))))
Deze routine print een boodschap
af op het
scherm en naar de transcript-file indien deze laatste bestaat. Het
gebruik ziet
er als volgt uit :
(message "test") print
op het scherm (zonder enter)
(message "test" nl) print
op het scherm (met enter)
(message "dit" nl "is"
nl" een test") geeft dan
(define message
(lambda string-list
(message-list string-list)))
Vraagt de gebruiker een yes/no
vraag. Het
resultaat en de vraag zelf worden ook naar de transcriptfile geschreven.
(define (Ask-Yes-No Phrase)
(flush-input)
(message Phrase " ? ")
(let ((char (read-char)))
(cond ((or (eq? char '#\Y)
(eq? char
'#\y))
(message "YES" nl)
#t)
((or
(eq? char '#\N) (eq? char
'#\n))
(message "NO" nl)
#f)
(else
(message nl)
(Ask-Yes-No Phrase)))))
Wacht tot de gebruiker een toets
indrukt. Van
deze actie wordt niets naar de transcriptfile geschreven.
(define (press-any-key)
(flush-input)
(if (eq? (char->integer
(read-char)) 0) (read-char))
#t)
Vraagt een filename aan de
gebruiker. Alles
wordt weeral naar de transcriptfile gedumpt.
(define (ask-filename)
(define answer)
(message "Filename : ")
(flush-input)
(set! answer (read-line))
(if transcript-file
(begin
(display answer
transcript-file)
(newline
transcript-file)))
answer)
Vraagt een expressie aan de
gebruiker. Weeral
een dump naar de transcriptfile en naar het scherm.
(define (ask-user)
(define answer)
(set! answer (read))
(if transcript-file
(begin
(display
answer transcript-file)
(newline
transcript-file)))
answer)
Deze functie maakt het
trace-window-pje leeg.
(define (clw)
(window-delete trace-window))
Grafisch
scherm
Constanten voor de definitie van
standaardkleuren en maximumcoordinaten.
(define maxx #f)
(define maxy #f)
(define background-color 'BLACK)
(define std-line-color 'GREEN)
(define std-point-color 'LIGHT-RED)
(define std-circle-color 'YELLOW)
De scaling constanten zodat het
scherm 400 bij
400 gemapt wordt naar het bestaande raster-scherm.
(define xfact #f)
(define xterm #f)
(define yfact #f)
(define yterm #f)
Dit berekent de coordinaten eens
in functie
van de meegegeven gevraagde bounds.
(define (set-xworld left top right
bottom)
(set! xterm (- left))
(set! yterm (- top))
(set! xfact (/ maxx (- right left)))
(set! yfact (/ maxy (- bottom top))))
Voort een nieuw coordinatenstelsel
in. Hierbij
steun ik nogal sterk op hetgeen PCS me aanreikt. (de functies set-coordinates! en set-point?-! heb ik
niet geschreven.)
(define (init-points)
(set-xworld -200 200 200 -200)
(set-point?-!
(lambda (p)
(and
(procedure?
p)
(point?
p))))
(set-coordinates!
(lambda (p)
(round (* (+ (p
'x) xterm)
xfact)))
(lambda (p)
(round (* (+ (p
'y) yterm)
yfact)))
(lambda (xy)
(make-point (car
xy) (cdr xy)))))
Initialiseert een nieuwe definitie
van afstand
zodat cirkels ook juist worden getekend. De functie set-distances!
is er weerom één van PCS.
(define (init-circles)
(set-fill-style 'EMPTY 'BLACK)
(set-distances!
(lambda (p k)
(round (* (k 'x)
xfact)))
(lambda (p k)
(round (* (k 'y)
yfact)))
(lambda (p k)
(error
"unary-dist,
circles"))))
Initialiseert de grafische
objecten door de
punten te registreren en de circles.
(define (init-graphical-objects)
(init-points)
(init-circles)
)
Maakt het grafische scherm leeg.
(define (cls)
(clear-viewport))
Hertekent het volledige scherm. De
untouchable
world wordt achter de global world getekend.
(define (redraw)
(cls)
(untouchable-world 'redraw)
((world 'redraw) 14))
Herinitializeert de werelden en
hertekent het
scherm
(define (reset-world)
(init-world)
(redraw))
Herinitialiseert de werelden
zonder het scherm
te hertekenen.
(define (init-world)
(world 'init)
(untouchable-world 'init))
Initialiseert een nieuwe
aspect-ratio zodat
circles getekend worden zoals ik ze vraag (en niet zoals de gebruiker
een
cirkel wil zien)
(define (init-graphics)
(init-graph)
(set-aspect-ratio '(1 . 1))
(set! maxx (car (get-max-xy)))
(set! maxy (cdr (get-max-xy)))
(%reify-port! pcs-status-window 11
(bitwise-and (%reify-port
pcs-status-window
11) -11))
(clear-device))
Error's
Hier is de definitie van de
error's
voorhanden. Deze is zo simpel dat er weinig uitleg bij moet.
(define (make-error info . text)
(list 'error info text))
(define (error? e)
(and (pair? e) (eq? (car e) 'error)))
(define (error-text e)
(caddr e))
(define (error-info e)
(cadr e))
Programma's
In : real lengte, angle voethoek,
component child
Out : arm result
Comments
:
(define (make-normal-arm lengte
voethoek child)
(make-arm lengte lengte lengte
voethoek child))
In : angle rotation, angle voethoek,
component child
Out : scharnier result
Comments
:
Dit scharnier wordt abnormaal
genoemd omdat
het geen minimum/maximum rotatiehoek heeft, hij kan volledig 360°
ronddraaien
zonder morren.
(define (make-abnormal-scharnier
rotation
voethoek child)
(make-scharnier 0 2PI rotation
voethoek child))
In : robot who, int x, int
y
Out : #t/error
Comments
: Deze routine zorgt dat de robot over (x,y) verplaatst. Hierbij worden
botsingen met andere robot's gecontroleerd. De meegegeven parameter who moet een robot-root zijn. Indien
niet zal er een error optreden.
(define (rel-move who speedx speedy)
((who 'right) (make-point speedx
speedy)))
In : arm who, real length
Out : #t/error
Comments
: Verandert de lengte van de meegegeven
arm. who mag ofwel een vaste-arm zijn, ofwel
een variabele arm. Bij het veranderen van de armlengte wordt
gecontroleerd of
de robot zichzelf niet snijdt, nadien wordt gecontroleerd of de globale
wereld
niet om zeep wordt geholpen.
(define (arm-length who new-length)
((who 'arm-length) new-length))
In : pen-component who
Out : #t
Comments
: Heft de pen op van het papier zodat,
als de robot
in het vervolg beweegt, geen lijnen meer worden getekend.
(define (pen-up who)
(who 'pen-up))
In : pen-component who
Out : #t
Comments
: Zet de pen op papier. De eerst volgende
keer dat
de pen wordt verplaatst. Bijvoorbeeld door een armbeweging of door het
verplaatsen van de robot zal er een lijn in kleur color
getekend worden. (color
is gedefinieerd bij het creëeren van de pen)
(define (pen-down who)
(who 'pen-down))
In : pen-component who, color
nieuwekleur
Out : #t
Comments
: Verandert de kleur van de meegegeven
pen. De
volgende keer dat een lijn moet getekend worden zal dit in de nieuwe
kleur
gebeuren.
(define (pen-color who nieuwekleur)
((who 'color!) nieuwekleur))
In : scharnier-component who,
angle angle
Out : #t/error
Comments
: Verandert de hoek van who,
indien mogelijk natuurlijk. Bij deze operatie worden geen interne,
noch externe snijdingen gecontroleerd.
(define (rotate who angle)
((who 'scharnier-angle) angle))
In : boor-component wie
Out : #t
Comments
: Boort een gat op de huidige plaats van
de boor.
Deze wordt voorgesteld door een rondje op de plaats waar geboord werd.
(define (boor wie)
(wie 'boor))
In : list lst
Out : 'done
Comments
: Deze routine creëert een nieuwe
scheme-omgeving
en laat de lijst van commando's erin runnen. Voor het uitvoeren van de
eerste
instructie worden al de voorgaande gegevens gewist. Na het uitvoeren
van lst worden nog eens al de werelden leeg
gemaakt.
Caution
: Er gebeurt geen controle op het
recursief
aanroepen van programma's. Dit zou dus tot erg onaangename verrassingen
kunnen
leiden.
(define (loop-program lst)
(let ((env (make-environment)))
(define (action wat)
(let ((result #f))
(message
wat nl wt)
(set!
result (eval wat env))
(if
(and (pair? wat) (eq? (car
wat) 'define))
(set! result (eval result
env)))
result))
(define (loop lst)
(if (null? lst)
#t
(let
((result (action (car
lst))))
(if (error? result)
(begin
(message " =>
" result nl wt)
(redraw)))
(loop (cdr lst)))))
(init-world)
(redraw)
(loop lst)
(init-world)
(redraw)
'done))
Demos
(define (demo)
(message "Programma 1" nl
wt)
(loop-program program1)
(message "Programma 2" nl
wt)
(loop-program program2)
(message "Programma 3" nl
wt)
(loop-program program3)
(message "Programma 4" nl
wt)
(loop-program program4)
(message "Programma 5" nl
wt)
(loop-program program5)
(message "Programma 6" nl
wt)
(loop-program program6)
(message "That's all folks
!" nl wt)
(init-world)
(redraw)
*the-non-printing-object*)
(define program1 '(
(define dennis-pen (make-pen 'WHITE))
(define dennis-arm2 (make-arm 0 100 50
0 dennis-pen))
(define dennis-arm2 (make-arm 10 49 50
0 dennis-pen))
(define dennis-arm2 (make-arm 10 100
50 0 dennis-pen))
(define dennis-arm1 (make-arm 10 100
50 (/ PI 6) dennis-arm2))
(define dennis (make-robot (make-point
0 0) PI/2 dennis-arm1))
(rel-move dennis 100 0)
(rel-move dennis 50 -100)
(pen-down dennis-pen)
(rel-move dennis -50 10)
(pen-color dennis-pen 'LIGHT-BLUE)
(rel-move dennis 10 100)
(pen-color dennis-pen 'LIGHT-GREEN)
(arm-length dennis-arm1 100)
(arm-length dennis-arm2 110)
(arm-length dennis-arm2 100)
(arm-length dennis-arm1 10)
(arm-length dennis-arm2 10)
))
(define program2 '(
(define ralf-arm4 (make-arm 10 200 50
PI/2 null-component))
(define ralf-arm3 (make-arm 10 200 20
PI/2 ralf-arm4))
(define ralf-arm2 (make-arm 10 200 80
PI/2 ralf-arm3))
(define ralf-arm1 (make-arm 10 200 70
PI/2 ralf-arm2))
(define ralf-voet (make-robot
(make-point 150 30) PI/2 ralf-arm1))
(arm-length ralf-arm4 70)
(arm-length ralf-arm4 90)
(arm-length ralf-arm4 110)
(arm-length ralf-arm3 100)
(arm-length ralf-arm2 200)
(arm-length ralf-arm3 100)
(arm-length ralf-arm2 80)
(arm-length ralf-arm4 100)
(arm-length ralf-arm1 100)
))
(define program3 '(
(define ralf-arm (make-normal-arm 200
0 null-component))
(define ralf
(make-robot (make-point -150
-30) (-
PI/2 (/ PI 8)) ralf-arm))
(define dennis-pen (make-pen 'BLUE))
(define dennis-arm2 (make-arm 10 200
30 0 dennis-pen))
(define dennis-arm1 (make-arm 10 200
30 (/ PI 4) dennis-arm2))
(define dennis (make-robot (make-point
150 30) (/ PI 4) dennis-arm1))
(arm-length ralf-arm 100)
(arm-length ralf-arm 250)
(pen-down dennis-pen)
(rel-move dennis -280 0)
(rel-move dennis -150 0)
(rel-move ralf 300 0)
(rel-move ralf 300 -20)
(rel-move dennis -100 -2.5)
(arm-length dennis-arm2 100)
(arm-length dennis-arm1 100)
))
(define program4 '(
(define circler-pen (make-pen 'BLUE))
(define circler-arm2 (make-normal-arm
100 0 circler-pen))
(define circler-rot2 (make-scharnier
(/ PI 4) PI/2 PI/2 0 circler-arm2))
(define circler-arm1 (make-normal-arm
100 0 circler-rot2))
(define circler-rot1
(make-abnormal-scharnier PI/2 0 circler-arm1))
(define circler (make-robot
(make-point 30 0) PI/2 circler-rot1))
(pen-down circler-pen)
(rotate circler-rot2 0)
(rotate circler-rot2 (/ PI 4))
(rotate circler-rot1 (/ PI 4))
(rotate circler-rot2 (/ PI 2))
(rotate circler-rot1 (/ PI 2))
))
(define program5 '(
(define circler-pen (make-pen 'GREEN))
(define circler-arm2 (make-normal-arm
100 0 circler-pen))
(define circler-rot2
(make-abnormal-scharnier
PI/2 (/ PI
8) circler-arm2))
(define circler-arm1 (make-normal-arm
100 (/ PI 8) circler-rot2))
(define circler-rot1
(make-abnormal-scharnier
PI/2 (/ PI
8) circler-arm1))
(define circler (make-robot
(make-point 30 0) (/ PI 4) circler-rot1))
(pen-down circler-pen)
(rotate circler-rot2 (/ PI 4))
(rotate circler-rot1 (/ PI 4))
(rotate circler-rot2 (/ PI 2))
(rotate circler-rot1 (/ PI 2))
))
(define program6 '(
(define boor-end (make-boor))
(define boormachien (make-robot
(make-point
0 0) 0 boor-end))
(boor boor-end)
(rel-move boormachien 0 -100)
(boor boor-end)
(rel-move boormachien 0 200)
(boor boor-end)
(rel-move boormachien -100 -100)
(boor boor-end)
(rel-move boormachien 200 0)
(boor boor-end)
))
Main
De my-random is een gewone
randomfunctie. Het
enige dat ik heb veranderd is dat de 0 nog steeds werkt. (De random van
PCS
loopt vast bij een 0)
(define (my-random x)
;deze heb ik moeten definieren omdat
die
;van PCS niet goed gaat
(if (= x 0)
0
(random
x)))
Een beetje show om aan te tonen
wie dit
programma gemaakt heeft : ikke, me, mezelf, and I.
(define (about)
(let* ((midx (/ maxx 2))
(midy
(/ maxy 2))
(mid-point
(cons midx midy))
(maxcolor
(get-max-color)))
(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
"Dennis")
(set-text-justify
'CENTER 'TOP)
(set-text-style
'DEFAULT 'horiz 1)
(out-text-xy
mid-point
"De
artificieel levende
robot in een gesimuleerde wereld")
(set-text-justify
'CENTER 'BOTTOM)
(out-text-xy
(cons midx (- maxy
45)) "Made by Werner Van Belle 1995")
(set-text-justify
'LEFT 'TOP)
(if (> count
0) (iter (-1+
count))))
(iter 30)
(iter 1)
(clear-device)
))
Initialiseert de application
(define (init-app)
(init-graphics)
(about)
(set! about #f) ;voor de gc
(init-trace-window 8)
(init-graphical-objects)
(init-transcript-file)
(init-world))
(define (close-app)
(close-transcript-file)
(close-graph)
*the-non-printing-object*)
Verloren Werk/Voorwerpen
In deze paragraaf worden de
ADT's besproken
die ik gedefinieerd en geïmplementeerd heb, maar die ik omwille van het
plaatsgebrek en de snelheid van PCS nooit heb kunnen gebruiken.
(zonde!). De
werkelijk gebruikte ADT's zijn gewoon afgeslankte versies van
onderstaande.
Breuken
Dit ADT vormt de
definitie van de breuken. Dit ADT is niet
gebruikt in
het project omdat het te veel geheugen vraagt en te traag werkt. Met
behulp van
de breuken kon ik met oneindig werken als ware het niets. Het geestige
was
natuurlijk wel dat er hier en daar toch nog altijd moest gecontroleerd
worden
of we niet met oneindig te maken hadden. Dit zou opgelost kunnen worden
(denk
ik) door bij elk rationaal getal een soort historiek bij te houden,
zodat de
operaties dan kunnen bedenken wat het meest wenselijke resultaat zou
zijn. Maar
aangezien dit geen project is om wiskundige structuren te definiëren
heb ik ze
er gewoon maar uit gelaten.
In : integer teller, integer
noemer
Out : breuk r
Comments : deze is als macro gedefiniëerd omwill van
performantie-redenen.
(macro %makeb (lambda (p)
`(cons ,(cadr p) ,(caddr p))))
In : breuk b
Out : real teller
(macro teller (lambda (p)
`(car ,(cadr p))))
In : breuk b
Out : real noemer
(macro noemer (lambda (p)
`(cdr ,(cadr p))))
In : integer teller, integer
noemer
Out : breuk r
Comments : creëert een breuk en zet ze onmiddelijk om naar een
intern
gewenst formaat. Normaal moet makeb
altijd worden aangeroepen en niet %makeb
(define (makeb t n)
(vereenvoudig (%makeb t n)))
In : something b
Out : bool r
Comments : geeft #t weer als b een
breuk is.
(define (breuk? b)
(pair? b))
In : breuk b
Out : bool r
Comments : deze functie geeft weer of de breuk +inf voorstelt.
(define (+inf? b)
(and (> (teller b) 0) (= (noemer b)
0)))
In : breuk b
Out : bool r
Comments : deze functie geeft weer of de breuk -inf voorstelt.
(define (-inf? b)
(and (< (teller b) 0) (= (noemer b)
0)))
In : breuk b
Out : bool r
Comments : deze functie geeft weer of de breuk -inf of +inf
voorstelt.
(define (inf? b)
(and (<> (teller b) 0) (=
(noemer b) 0)))
In : breuk b
Out : bool r
Comments : deze functie geeft weer of de breuk +0 voorstelt.
(define (+zero? b)
(and (> (noemer b) 0) (= (teller b)
0)))
In : breuk b
Out : bool r
Comments : deze functie geeft weer of de breuk -0 voorstelt.
(define (-zero? b)
(and (< (noemer b) 0) (= (teller b)
0)))
In : breuk b
Out : bool r
Comments : deze functie geeft weer of de breuk 0 voorstelt.
(define (bzero? b)
(and (<> (noemer b) 0) (=
(teller b) 0)))
In : breuk b
Out : bool r
Comments : kijkt of b voorgesteld
kan worden als een reëel getal.
(define (is-real? b)
(<> (noemer b) 0))
In : breuk b
Out : bool r
Comments : kijkt of b geen reëel
getal is. Deze functie verschilt van inf? omdat 0/0 geen reëel getal is
maar
ook niet oneindig.
(define (is-no-real? b)
(= (noemer b) 0))
In : breuk b
Out : bool r
Comments : geeft #f weer als de breuk negatief is.
(define (bpositive? b)
(>b b 0b))
In : breuk b
Out : nothing
Comments : print de breuk af. Mogelijk uitvoer is
+inf
-inf
+0
-0
teller/noemer
(define (display-breuk b)
(cond ((+inf? b) (message
"+inf"))
((-inf?
b) (message "-inf"))
((+zero?
b) (message
"+0"))
((-zero?
b) (message
"-0"))
((=
(noemer b) 1) (message
(teller b)))
(else
(message
(teller b))
(message
"/")
(message
(noemer b)))))
In : breuk b
Out : breuk r
Comments : de breuk wordt vereenvoudigd en naar buiten gegeven.
Normaal moet
deze functie niet aangeroepen worden. Elke operatie zal deze vanzelf
aanroepen.
(define (vereenvoudig b)
(cond ((and (= (teller b) 0) (=
(noemer b) 0))
(error
"Creating
nan"))
((inf?
b)
(if
(+inf? b) (%makeb 1 0)
(%makeb -1 0)))
((bzero?
b)
(if
(+zero? b) (%makeb 0 1)
(%makeb 0 -1)))
(else
(if
(< (noemer b) 0)
(set! b (%makeb (- (teller
b)) (- (noemer b)))))
(let
((deeldoor (gcd (teller
b) (noemer b))))
(%makeb (quotient (teller b)
deeldoor)
(quotient (noemer b)
deeldoor))))))
In : breuk b
Out : breuk r
Comments : maakt het inverse van b.
Indien b + oneindig was, zal b nadien
+0 zijn. Evenzo voor -oneindig
(define (inverse b)
(makeb (noemer b) (teller b)))
In : breuk b, integer g
Out : breuk r
Comments : Vermenigvuldigt g met b
en geeft het resultaat weer. Hier
wordt niet gecontroleerd of g wel een
integer is. Desalwelteplus zal dit zeker niet tot errors leiden.
(define (b*g b g)
(*b b (makeb g 1)))
In : breuk q
Out : integer z
Comments
: geeft het gehele deel van de breuk
weer, indien
mogelijk. Er wordt geen error-checking gedaan.
(define (q->z q)
(quotient (teller q) (noemer q)))
In : breuk b1, breuk b2
Out : breuk r
Comments
: vermenigvuldigt b1 met
b2. Hier wordt
error-checking gedaan voor operaties zoals 0 vermenigvuldigt met
oneindig.
(define (*b b1 b2)
(makeb (* (teller b1) (teller b2))
(*
(noemer b1) (noemer b2))))
In : breuk b1, breuk b2
Out : breuk r
Comments
: deelt b1
met b2. Hier wordt error-checking
gedaan voor operaties zoals 0 vermenigvuldigt met oneindig.
(define (/b b1 b2)
(*b b1 (inverse b2)))
In : breuk b1, breuk b2
Out : breuk r
Comments
: telt b1
bij b2 en geeft het resultaat weer.
Geen error-checking op oneindig.
(define (+b b1 b2)
(makeb (+ (* (teller b1) (noemer b2))
(* (teller b2) (noemer b1)))
(*
(noemer b1) (noemer b2))))
In : breuk b1, breuk b2
Out : breuk r
Comments
: trekt b2
af van b1 en geeft het resultaat
weer. Geen error-checking op oneindig.
(define (-b b1 b2)
(makeb (- (* (teller b1) (noemer b2))
(* (teller b2) (noemer b1)))
(*
(noemer b1) (noemer b2))))
In : breuk b1, breuk b2
Out : bool r
Comments
: controleert of b1
gelijk is aan b2. Geen
problemen met oneindig en dergelijke.
(define (=b b1 b2)
(and (= (teller b1) (teller b2))
(= (noemer
b1) (noemer b2))))
In : breuk b1, breuk b2
Out : bool r
Comments
: geeft weer of b1>b2. Bij definitie
(mijn
definitie althans) is +oneindig niet groter dan +oneindig en -oneindig
niet
kleiner dan -oneindig.
(define (>b b1 b2)
(cond ((or (and (+inf? b1) (+inf? b2))
(and (-inf? b1) (-inf?
b2))) #f)
((and
(-inf? b1) (+inf? b2)) #f)
((and
(+inf? b1) (-inf? b2)) #t)
(else
(if
(-zero? b1) (set! b1 0B))
(if
(-zero? b2) (set! b2 0B))
(>
(* (teller b1) (noemer
b2))
(* (noemer b1) (teller
b2)))))))
In : breuk b1, breuk b2
Out : bool r
Comments : geeft weer of 
Deze functie steunt
volledig op de definitie
van >b en =b.
(define (>=b b1 b2)
(or (=b b1 b2) (>b b1 b2)))
In : breuk b1, breuk b2
Out : bool r
Comments
: geeft weer of 
Deze functie steunt
volledig op de definitie van >b en =b.
(define (<b b1 b2)
(not (>=b b1 b2)))
In : breuk b1, breuk b2
Out : bool r
Comments
: geeft weer of 
Deze functie steunt
volledig op de definitie van >b.
(define (<=b b1 b2)
(not (>b b1 b2)))
In : breuk b
Out : real r
Comments : Converteert b naar een
bijhorend reëel getal. Hier wordt geen error-checking gedaan voor het
geval
oneindig.
(define (b->r b)
(/ (teller b) (noemer b)))
In : integer g
Out : breuk r
Comments : converteert het meegegeven getal naar een breuk. Dit
had eigelijk
een macro kunnen zijn.
(define (g->b g)
(makeb g 1))
In : breuk a
Out : breuk b
Comments
: Het absolute deel van a
wordt weergegeven. Geen probleem voor +inf, -inf, nan, +0 &
-0.
(define (babs a)
(makeb (abs (teller a))
(abs
(noemer a))))
Definities van vaak gebruikte
rationale
getallen.
(define 0B (makeb 0 1))
(define 1B (makeb 1 1))
(define +inf (makeb 1 0))
(define -inf (makeb -1 0))
Oorspronkelijke
Grenzen
In : real coefficient,
open/gesloten
Out : grens
Comments : deze grenzen waren nodig om nadien de
half-open/open/gesloten
intervallen te definieren.
(define (make-grens coefficient
open-of-gesloten)
(if (inf? coefficient) (set!
open-of-gesloten open))
(cons coefficient open-of-gesloten))
Definitie van
open/gesloten
(define open 'open)
(define gesloten 'gesloten)
In : grens grens
Out : bool r
Comments : Geeft #t weer als dit een open grens is.
(define (open?
grens)
(eq? open (cdr grens)))
In : grens grens
Out : bool r
Comments : Geeft #t weer als dit een gesloten grens is.
(define (gesloten? grens)
(eq? gesloten (cdr grens)))
In : grens grens
Out : open/gesloten r
Comments : geeft weer of r open of
gesloten is. Deze kan nadien gecontroleerd worden met eq?
(define (open-gesloten? grens)
(cdr grens))
In : grens grens
Out : real r
Comments : Geeft de grens-waarde naar buiten
(define (coef grens)
(car grens))
In : grens grens, real new-coef
Out : grens r
Comments : Maakt een nieuwe grens waarbij de open/gesloten
gecopieerd wordt van grens, en de coefficiënt van new-coef
(define (change-coef grens naar)
(make-grens naar (open-gesloten?
grens)))
Oorspronkelijk
Interval
In : grens from-grens, grens
to-grens
Out : interval r
Comments : Het ADT Interval is gedefinieerd als een
struktuur met een verzameling
operaties. Error-gevallen zijn de volgende intervallen :
[a;a[ of
]a;a]
]-inf;-inf[
]+inf;+inf[
(define (make-interval
from-grens to-grens)
(if (or
(and
(=b
(coef from-grens) (coef
to-grens))
(not
(eq? (open-gesloten?
from-grens)
(open-gesloten?
to-grens))))
(and
(-inf? (coef from-grens))
(-inf? (coef to-grens)))
(and
(+inf? (coef from-grens))
(+inf? (coef to-grens))))
(error "creating
some stupid
interval")
(cons from-grens
to-grens)))
Definitie van het eenheidsinterval
en van de
reële rechte. In het draaiende programma is deze rechte vervangen door
de
functie make-horizon
(define I1
(make-interval
(make-grens 0b 'gesloten)
(make-grens 1b 'gesloten)))
(define IR (make-interval (make-grens -inf 'open) (make-grens +inf
open)))
In : interval interval
Out : grens from-grens van
interval interval
(define (from-grens interval)
(car interval))
In : interval interval
Out : grens to-grens van
interval interval
(define (to-grens interval)
(cdr interval))
In : interval i
Out : bool b
Comments : Indien de sluiting van i
slechts uit één punt bestaat wordt #t weergegeven, in het andere geval
wordt #f
geretourneerd.
(define (punt-interval? i)
(=b (coef (from-grens i)) (coef
(to-grens i))))
In : interval who
Out : nothing
Comments : print het interval af onder de vorm "[from,to[". De
haakjes
staan naar gelang de grenzen open of gesloten zijn.
(define (display-interval who)
(message (if (open? (from-grens who))
"]" "["))
(display-breuk (coef (from-grens
who)))
(message ",")
(display-breuk (coef (to-grens who)))
(message (if (open? (to-grens who))
"[" "]")))
In : interval interval
Out : interval r
Comments : r is het interval dat
voldoet aan de voorwaarde 
.
Omdat dit ADT enkel functioneel gebruikt kan worden moet er
geen copie gemaakt worden indien het interval reeds geordend is.
(define (orden-interval interval)
(if (>b (coef (from-grens
interval)) (coef (to-grens interval)))
(make-interval
(to-grens interval)
(from-grens interval))
interval))
In : real p, interval CD
Out : bool r
Comments : indien p op het
interval CD ligt zal #t worden
weergegeven. #f in het andere geval. Merk op dat CD
als gesloten interval beschouwd wordt.
(define (punt-op-interval? p CD)
(set! CD (orden-interval CD))
(let ((Cg (from-grens CD))
(Dg
(to-grens CD)))
(if (punt-interval? CD)
(=b p
(coef Cg))
(and
((if (open? Cg) >b
>=b) p (coef Cg))
((if (open? Dg) <b
<=b) p (coef Dg))))))
In : interval AB, interval CD
Out : interval result
Comments : deze functie maakt de snijding van twee intervallen.
Geen van
beide moet op voorhand geordend zijn.
(define (intersect-interval AB
CD)
(define (leftgrens most-left other)
(if (and (=b (coef most-left)
(coef
other)) (open? most-left))
(make-grens
(coef other) open)
other))
(define (rightgrens most-left other)
(if (and (=b (coef most-left)
(coef
other)) (open? other))
(make-grens
(coef most-left)
open)
most-left))
(let ((Ag (from-grens AB))
(Bg
(to-grens AB))
(Cg
(from-grens CD))
(Dg
(to-grens CD)))
(cond ((punt-interval? AB)
(if
(punt-op-interval? (coef Ag) CD) AB))
((punt-interval?
CD) (if
(punt-op-interval? (coef CD) AB) CD))
((begin
(set! AB (orden-interval
AB))
(set! CD (orden-interval
CD))
#f) (error "Dit is een
actie geen predicaat"))
((<b
(coef Cg) (coef Ag))
(intersect-interval CD AB))
((<=b
(coef Dg) (coef Bg))
(make-interval (leftgrens Ag
Cg) (rightgrens Dg Bg)))
((<=b
(coef Cg) (coef Bg))
(make-interval (leftgrens Ag
Cg) (rightgrens Bg Dg)))
((and
(=b (coef Bg) (coef Cg))
(gesloten? Bg) (gesloten? Cg))
(make-interval Bg Bg))
(else
#f))))
Het
T-stuk
In het programma had ik ook een
T-stuk
gedefinieerd, maar deze was helemaal onhandelbaar geworden. Zonder dat
er
fouten in de code staken was een robot waar een T-stuk in voorkwam
amper in
staat zich te verplaatsen bij gebrek aan stack-space.
De code is niet gedocumenteerd
omdat het
een typische component is.
(define (T-drawing aantal)
(let ((point-list (list (make-point 0
0)))
(x 0))
(define (loop nr)
(if (= nr 0)
point-list
(begin
(set! point-list
(append point-list
(list
(make-point x 10)
(make-point x 20)
(make-point (+ x 5)
20)
(make-point (+ x 5)
10)
)))
(set! x (+ x 20))
(loop (- nr 1)))))
(loop aantal)
(%make-L-vlak (append
point-list
(list (make-point x 0))))))
(define make-T
(lambda childs
(let ((aantal (length childs))
(parent
#f)
(drawing
#f)
(last-pos
#f)
(last-angle
#f)
(sub-world
#f))
(define (set-sub-world! to)
(set! sub-world
to))
(define (set-drawing! to)
(set! drawing to))
(define (glue father)
(if parent
#f
(begin
(set! parent father)
(for-each
(lambda (child)
((child 'glue) T-self))
childs)
#t)))
(define (unglue)
(set! parent #f)
(for-each
(lambda
(child) (child 'unglue))
childs))
(define (drawing@ pos angle)
(((((T-drawing
aantal)
'rotate)
(make-point 0 0)
angle)
'translate)
pos))
(define (valid-init?)
#t)
(define (calc-end-point pos angle nr)
(((((make-point
(* 20 nr) 20)
'rotate)
(make-point 0 0)
angle)
'translate)
pos))
(define (sign-in-world sw pos angle)
(let ((nr 0))
(set!
last-angle angle)
(set!
last-pos pos)
(set!
drawing (drawing@ pos
angle))
((sw
'sign-in) T-self drawing)
(for-each
(lambda
(child)
((child 'sign-in-world)
sw
(calc-end-point pos angle
nr)
(+ angle PI/2))
(set! nr (+ nr 1)))
childs)))
(define (kill-set)
(define result
(make-set childs))
((result 'add!)
parent)
((result 'add!)
T-self)
result)
(define (translate-action naar)
(set! last-pos
((last-pos
'translate) naar))
(for-each
(lambda
(child)
((child
'translate-action)
naar))
childs))
(define (add-translate-sleeppad! result-in howmuch)
((result-in
'add!) ((drawing
'translate-sleep) howmuch))
(for-each
(lambda
(child)
((child
'add-translate-sleeppad!) result-in howmuch))
childs))
(define (change-translate-world! result-in howmuch)
((result-in
'%replace-drawing!)
drawing
((drawing
'translate) howmuch))
(for-each
(lambda
(child)
((child
'change-translate-world!) result-in howmuch))
childs))
(define (child-list)
(let ((result
(list T-self)))
(for-each
(lambda
(child)
(append (child 'child-list)
result))
childs)
result))
(define (T-self m)
(cond ((eq? m
'glue) glue)
((eq? m 'unglue) (unglue))
((eq? m 'set-sub-world!)
set-sub-world!)
((eq? m 'set-drawing!)
set-drawing!)
((eq? m 'kill-set)
(kill-set))
((eq? m 'sign-in-world)
sign-in-world)
((eq? m 'translate-action)
translate-action)
((eq? m
'change-translate-world!) change-translate-world!)
((eq? m 'child-list)
(child-list))
((eq? m
'add-translate-sleeppad!) add-translate-sleeppad!)
(else (error "T-stuk"
m))))
(let
((error-result (valid-init?)))
(if (error?
error-result)
error-result
T-self)))))
Uitgevoerde tests
Hieronder staat
een groot deel van de tests die ik uitgevoerd heb. Dat
de nummering niet doorloopt is omdat de ontbrekende stukken,
programma's waren
in een debug-toestand. M.a.w. De tests van de voorgaande nummers waren
gecopierd maar de code is verandert.
Robot02.scm
;Test1
Test open & gesloten met verschillende coefs
;-----
(define a (makep (g->b 1) (g->b 2)))
(define b (makep (g->b 5) (g->b 3)))
(define c)
(define d)
(define a->)
(define <-a)
(define l (make-line a b (create-interval (create-grens 0b gesloten)
create-grens 1b open))))
(display "Test1 ")
(view (and (%p-op-l a l) (not (%p-op-l b l))))
;Test2 Test
gesloten met dezelfde coefs
;-----
(set! l (make-line a b (create-interval (create-grens 1b gesloten)
(create-grens 1b gesloten))))
(display "Test2 ")
(view (and (not (%p-op-l a l)) (%p-op-l b l)))
;Test3
Test open met dezelfde coefs
;-----
(set! l (make-line a b (create-interval (create-grens 0b open)
(create-grens 0b
open))))
(display "Test3 ")
(view (and (not (%p-op-l a l)) (not (%p-op-l b l))))
;Test4
test een punt dat er totaal naast ligt
;-----
(set! l (make-line a b (create-interval (create-grens 0b gesloten)
(create-grens 1b open))))
(set! a (makep (g->b 5) (g->b 5)))
(display "Test4 ")
(view (not (%p-op-l a l)))
;Test5
oneindig testen op vertikale lijnen
;-----
(set! a (makep (g->b 5) (g->b 5)))
(set! c (makep (g->b 5) (g->b 100000)))
(set! d (makep (g->b 5) (g->b -10000)))
(set! <-a (make-line a b (create-interval (create-grens -inf open)
(create-grens 0b open))))
(set! a-> (make-line a b (create-interval (create-grens 0b open)
(create-grens +inf open))))
(display "Test5 ")
(view (not (%p-op-l a <-a)) ) ;a mag
niet op <-a liggen
(view (not (%p-op-l a a->)) ) ;a mag
ook niet op a-> liggen
(view (%p-op-l c <-a)
) ;c ligt op <-a
(view (not (%p-op-l c a->)) ) ;c
ligt niet op a->
(view (not (%p-op-l d <-a)) ) ;d
ligt niet op <-a
(view (%p-op-l d a->)
) ;d ligt op ->a
;Test6
oneindig testen op horizontale lijnen
;-----
(set! a (makep (g->b 8) (g->b 3)))
(set! c (makep (g->b 100002) (g->b 3)))
(set! d (makep (g->b -256) (g->b 3)))
(set! <-a (make-line a b (create-interval (create-grens -inf open)
(create-grens 0b open))))
(set! a-> (make-line a b (create-interval (create-grens 0b open)
(create-grens +inf open))))
(display "Test6 ")
(view (not (%p-op-l a <-a)) ) ;a mag
niet op <-a liggen
(view (not (%p-op-l a a->)) ) ;a mag
ook niet op a-> liggen
(view (%p-op-l c <-a)
) ;c ligt op <-a
(view (not (%p-op-l c a->)) ) ;c
ligt niet op a->
(view (not (%p-op-l d <-a)) ) ;d
ligt niet op <-a
(view (%p-op-l d a->)
) ;d ligt op ->a
;Test7
oneindig testen op horizontale lijnen
;-----
(set! a (makep (g->b 7) (g->b 4)))
(set! c (makep (g->b 9) (g->b 5)))
(set! d (makep (g->b 3) (g->b 2)))
(set! <-a (make-line a b (create-interval (create-grens -inf open)
(create-grens 0b open))))
(set! a-> (make-line a b (create-interval (create-grens 0b open)
(create-grens +inf open))))
(display "Test7 ")
(view (not (%p-op-l a <-a)) ) ;a mag
niet op <-a liggen
(view (not (%p-op-l a a->)) ) ;a mag
ook niet op a-> liggen
(view (%p-op-l c <-a)
) ;c ligt op <-a
(view (not (%p-op-l c a->)) ) ;c
ligt niet op a->
(view (not (%p-op-l d <-a)) ) ;d
ligt niet op <-a
(view (%p-op-l d a->)
) ;d ligt op ->a
Robot03.scm
;---------------------------------------------------------
;test1 : testen van vertikaal samenvallende rechten
;---------------------------------------------------------
(define x (makeb 50 1))
(define (fast-line fromx fromy tox toy fromcoef from-og tocoef to-og)
(define (mb watte)
(if (breuk? watte)
watte
(makeb
watte 1)))
(make-line
(make-point (mb fromx) (mb
fromy))
(make-point (mb tox) (mb toy))
(make-interval
(make-grens (mb
fromcoef) from-og)
(make-grens (mb
tocoef) to-og))))
(define A (fast-line x 0 x -2 -3
gesloten -inf
open))
(define B (fast-line x 0 x -2 (makeb 3 2) open (makeb -3 2) gesloten))
(define C (fast-line x 12 x 6 1 gesloten +inf open))
(define D (fast-line x 0 x 1 0 gesloten +inf open))
(define E (fast-line x 0 x 1 -inf gesloten +inf open))
(message "A -> ") (A 'display)
(crlf)
(message "B -> ") (B 'display) (crlf)
(message "C -> ") (C 'display) (crlf)
(message "D -> ") (D 'display) (crlf)
(message "E -> ") (E 'display) (crlf)
(message "A i A -> ") (view
(intersect-l-l A A))
(message "A i b -> ") (view (intersect-l-l A b))
(message "A i c -> ") (view (intersect-l-l A c))
(message "A i d -> ") (view (intersect-l-l A d))
(message "b i A -> ") (view (intersect-l-l b A))
(message "b i b -> ") (view (intersect-l-l b b))
(message "b i c -> ") (view (intersect-l-l b c))
(message "b i d -> ") (view (intersect-l-l b d))
(message "c i A -> ") (view (intersect-l-l c A))
(message "c i b -> ") (view (intersect-l-l c b))
(message "c i c -> ") (view (intersect-l-l c c))
(message "c i d -> ") (view (intersect-l-l c d))
(message "d i A -> ") (view (intersect-l-l d A))
(message "d i b -> ") (view (intersect-l-l d b))
(message "d i c -> ") (view (intersect-l-l d c))
(message "d i d -> ") (view (intersect-l-l d d))
(message "E i E -> ") (view (intersect-l-l E e))
;---------------------------------------------------------
;test2 : testen van vertikaal samenvallende rechten
;---------------------------------------------------------
(set! A (fast-line 0 x -2 x -3 gesloten -inf
open))
(set! B (fast-line 0 x -2 x (makeb 3 2) open (makeb -3 2) gesloten))
(set! C (fast-line 12 x 6 x 1 gesloten +inf open))
(set! D (fast-line 0 x 1 x 0 gesloten +inf open))
(set! E (fast-line 0 x 1 x -inf gesloten +inf open))
(message "A -> ") (A 'display)
(crlf)
(message "B -> ") (B 'display) (crlf)
(message "C -> ") (C 'display) (crlf)
(message "D -> ") (D 'display) (crlf)
(message "E -> ") (E 'display) (crlf)
(message "A i A -> ") (view
(intersect-l-l A A))
(message "A i b -> ") (view (intersect-l-l A b))
(message "A i c -> ") (view (intersect-l-l A c))
(message "A i d -> ") (view (intersect-l-l A d))
(message "b i A -> ") (view (intersect-l-l b A))
(message "b i b -> ") (view (intersect-l-l b b))
(message "b i c -> ") (view (intersect-l-l b c))
(message "b i d -> ") (view (intersect-l-l b d))
(message "c i A -> ") (view (intersect-l-l c A))
(message "c i b -> ") (view (intersect-l-l c b))
(message "c i c -> ") (view (intersect-l-l c c))
(message "c i d -> ") (view (intersect-l-l c d))
(message "d i A -> ") (view (intersect-l-l d A))
(message "d i b -> ") (view (intersect-l-l d b))
(message "d i c -> ") (view (intersect-l-l d c))
(message "d i d -> ") (view (intersect-l-l d d))
(message "E i E -> ") (view (intersect-l-l E e))
;------------------------------------------
;test3 : kruisingen horizontaal & vertikaal
;------------------------------------------
(set! A (fast-line 0 0 1 0 -inf gesloten
+inf open))
(set! B (fast-line 0 0 0 1 -inf gesloten +inf open))
(set! C (fast-line 123 -1 123 5 0 gesloten 1 gesloten))
(set! D (fast-line 124 -1 124 5 1 open 2 gesloten))
(set! E (fast-line 120 11 119 11 0 open -30 gesloten))
(define F (fast-line 120 12 119 12 150 open 0 open))
(message "A -> ") (A 'display)
(crlf)
(message "B -> ") (B 'display) (crlf)
(message "C -> ") (C 'display) (crlf)
(message "D -> ") (D 'display) (crlf)
(message "E -> ") (E 'display) (crlf)
(message "F -> ") (F 'display) (crlf)
(message "A i A -> ") (view
(intersect-l-l A A))
(message "A i b -> ") (view (intersect-l-l A b))
(message "A i c -> ") (view (intersect-l-l A c))
(message "A i d -> ") (view (intersect-l-l A d))
(message "A i e -> ") (view (intersect-l-l A e))
(message "A i f -> ") (view (intersect-l-l A f))
(message "b i A -> ") (view (intersect-l-l b A))
(message "b i b -> ") (view (intersect-l-l b b))
(message "b i c -> ") (view (intersect-l-l b c))
(message "b i d -> ") (view (intersect-l-l b d))
(message "b i e -> ") (view (intersect-l-l b e))
(message "b i f -> ") (view (intersect-l-l b f))
(message "c i A -> ") (view (intersect-l-l c A))
(message "c i b -> ") (view (intersect-l-l c b))
(message "c i c -> ") (view (intersect-l-l c c))
(message "c i d -> ") (view (intersect-l-l c d))
(message "c i e -> ") (view (intersect-l-l c e))
(message "c i f -> ") (view (intersect-l-l c f))
(message "d i A -> ") (view (intersect-l-l d A))
(message "d i b -> ") (view (intersect-l-l d b))
(message "d i c -> ") (view (intersect-l-l d c))
(message "d i d -> ") (view (intersect-l-l d d))
(message "d i e -> ") (view (intersect-l-l d e))
(message "d i f -> ") (view (intersect-l-l d f))
(message "e i A -> ") (view (intersect-l-l e A))
(message "e i b -> ") (view (intersect-l-l e b))
(message "e i c -> ") (view (intersect-l-l e c))
(message "e i d -> ") (view (intersect-l-l e d))
(message "e i e -> ") (view (intersect-l-l e e))
(message "e i f -> ") (view (intersect-l-l e f))
(message "f i A -> ") (view (intersect-l-l f A))
(message "f i b -> ") (view (intersect-l-l f b))
(message "f i c -> ") (view (intersect-l-l f c))
(message "f i d -> ") (view (intersect-l-l f d))
(message "f i e -> ") (view (intersect-l-l f e))
(message "f i f -> ") (view (intersect-l-l f f))
Robot04.scm
Test1 tot en met 3
werden gecopierd van Robot03.scm
;-------------------------------------------------
;test4 : horizontale lijnen snijden met schuine
;-------------------------------------------------
(message "Test 4")
(crlf)
(set! A (fast-line -10 5 20 5 0
gesloten 1 gesloten))
(set! B (fast-line -10 -5 20 -5 -inf
gesloten +inf gesloten))
(set! C (fast-line 18 12 15 6 0
gesloten 1 gesloten))
(set! D (fast-line 20 12 17 6 0 open
+inf open))
(set! E (fast-line 20 3 19 -3 0 open
-inf open))
(message "A -> ") (A 'display)
(crlf)
(message "B -> ") (B 'display) (crlf)
(message "C -> ") (C 'display) (crlf)
(message "D -> ") (D 'display) (crlf)
(message "E -> ") (E 'display) (crlf)
(message "A i A -> ") (view
(intersect-l-l A A))
(message "A i b -> ") (view (intersect-l-l A b))
(message "A i c -> ") (view (intersect-l-l A c))
(message "A i d -> ") (view (intersect-l-l A d))
(message "A i e -> ") (view (intersect-l-l A e))
(message "b i A -> ") (view (intersect-l-l b A))
(message "b i b -> ") (view (intersect-l-l b b))
(message "b i c -> ") (view (intersect-l-l b c))
(message "b i d -> ") (view (intersect-l-l b d))
(message "b i e -> ") (view (intersect-l-l b e))
(message "c i A -> ") (view (intersect-l-l c A))
(message "c i b -> ") (view (intersect-l-l c b))
(message "d i A -> ") (view (intersect-l-l d A))
(message "d i b -> ") (view (intersect-l-l d b))
(message "e i A -> ") (view (intersect-l-l e A))
(message "e i b -> ") (view (intersect-l-l e b))
;-------------------------------------------------
;test5 : vertikale lijnen snijden met schuine
;-------------------------------------------------
(message "Test 5")
(crlf)
(set! A (fast-line 5 -10 5 20 0 gesloten 1
gesloten))
(set! B (fast-line -5 -10 -5 20 -inf gesloten +inf gesloten))
(set! C (fast-line 12 18 6 15 0 gesloten 1
gesloten))
(set! D (fast-line 12 20 6 17 0 open
+inf open))
(set! E (fast-line 3 20 -3 19 0 open
-inf open))
(message "A -> ") (A 'display)
(crlf)
(message "B -> ") (B 'display) (crlf)
(message "C -> ") (C 'display) (crlf)
(message "D -> ") (D 'display) (crlf)
(message "E -> ") (E 'display) (crlf)
(message "A i A -> ") (view
(intersect-l-l A A))
(message "A i b -> ") (view (intersect-l-l A b))
(message "A i c -> ") (view (intersect-l-l A c))
(message "A i d -> ") (view (intersect-l-l A d))
(message "A i e -> ") (view (intersect-l-l A e))
(message "b i A -> ") (view (intersect-l-l b A))
(message "b i b -> ") (view (intersect-l-l b b))
(message "b i c -> ") (view (intersect-l-l b c))
(message "b i d -> ") (view (intersect-l-l b d))
(message "b i e -> ") (view (intersect-l-l b e))
(message "c i A -> ") (view (intersect-l-l c A))
(message "c i b -> ") (view (intersect-l-l c b))
(message "d i A -> ") (view (intersect-l-l d A))
(message "d i b -> ") (view (intersect-l-l d b))
(message "e i A -> ") (view (intersect-l-l e A))
(message "e i b -> ") (view (intersect-l-l e b))
;---------------------------------------------------------
;test6 : testen van schuin samenvallende rechten
;---------------------------------------------------------
(message "Test 6")
(crlf)
(set! A (fast-line 200 0 198 -2
-3 gesloten -inf open))
(set! B (fast-line 200 0 198 -2 (makeb
3 2) open (makeb -3 2) gesloten))
(set! C (fast-line 212 12 206 6 1
gesloten +inf open))
(set! D (fast-line 200 0 201 1 0
gesloten +inf open))
(set! E (fast-line 200 0 201 1 -inf
gesloten +inf open))
(message "A -> ") (A 'display)
(crlf)
(message "B -> ") (B 'display) (crlf)
(message "C -> ") (C 'display) (crlf)
(message "D -> ") (D 'display) (crlf)
(message "E -> ") (E 'display) (crlf)
(message "A i A -> ") (view
(intersect-l-l A A))
(message "A i b -> ") (view (intersect-l-l A b))
(message "A i c -> ") (view (intersect-l-l A c))
(message "A i d -> ") (view (intersect-l-l A d))
(message "b i A -> ") (view (intersect-l-l b A))
(message "b i b -> ") (view (intersect-l-l b b))
(message "b i c -> ") (view (intersect-l-l b c))
(message "b i d -> ") (view (intersect-l-l b d))
(message "c i A -> ") (view (intersect-l-l c A))
(message "c i b -> ") (view (intersect-l-l c b))
(message "c i c -> ") (view (intersect-l-l c c))
(message "c i d -> ") (view (intersect-l-l c d))
(message "d i A -> ") (view (intersect-l-l d A))
(message "d i b -> ") (view (intersect-l-l d b))
(message "d i c -> ") (view (intersect-l-l d c))
(message "d i d -> ") (view (intersect-l-l d d))
(message "E i E -> ") (view (intersect-l-l E e))
;---------------------------------------------------------
;test7 : testen van snijdende rechten
;---------------------------------------------------------
(message "Test 7")
(crlf)
(set! A (fast-line (makeb 1 2) (makeb 3 2) -1 1 -1 gesloten 1 open))
(set! B (fast-line (makeb 1 2) (makeb 3 2) -1 1 -1 gesloten 1 gesloten))
(set! C (fast-line (makeb -3 2) 3 -2 5 -1 gesloten 1 gesloten))
(set! D (fast-line 2 2 0 (makeb 35 10) 0 gesloten 2 gesloten))
(message "A -> ") (A 'display)
(crlf)
(message "B -> ") (B 'display) (crlf)
(message "C -> ") (C 'display) (crlf)
(message "D -> ") (D 'display) (crlf)
(message "A i A -> ") (view
(intersect-l-l A A))
(message "A i b -> ") (view (intersect-l-l A b))
(message "A i c -> ") (view (intersect-l-l A c))
(message "A i d -> ") (view (intersect-l-l A d))
(message "b i A -> ") (view (intersect-l-l b A))
(message "b i b -> ") (view (intersect-l-l b b))
(message "b i c -> ") (view (intersect-l-l b c))
(message "b i d -> ") (view (intersect-l-l b d))
(message "c i A -> ") (view (intersect-l-l c A))
(message "c i b -> ") (view (intersect-l-l c b))
(message "c i c -> ") (view (intersect-l-l c c))
(message "c i d -> ") (view (intersect-l-l c d))
(message "d i A -> ") (view (intersect-l-l d A))
(message "d i b -> ") (view (intersect-l-l d b))
(message "d i c -> ") (view (intersect-l-l d c))
(message "d i d -> ") (view (intersect-l-l d d))
Robot06.scm
Dit waren de test voor het
controleren van de punt-in? operatie
;------------------
;test1 : rechthoek
;------------------
(define (fast-line fromx fromy tox toy)
(define (mb watte)
(if (breuk? watte)
watte
(makeb
watte 1)))
(make-line
(make-point (mb fromx) (mb
fromy))
(make-point (mb tox) (mb toy))
I1))
(define (fast-point x y)
(define (mb watte)
(if (breuk? watte)
watte
(makeb
watte 1)))
(make-point (mb x) (mb y)))
(define V1
(make-graph-set
(fast-line -10 -10 -10 10)
(fast-line
-10 10 10 10)
(fast-line 10 10 10 -10)
(fast-line 10 -10 -10 -10)))
(define p1
(fast-point -20 -20))
(define p2 (fast-point -10 -20))
(define p3 (fast-point
0 -20))
(define p4 (fast-point
10 -20))
(define p5 (fast-point
20 -20))
(define p6
(fast-point -20 -10))
(define p7 (fast-point -10 -10))
(define p8 (fast-point
0 -10))
(define p9 (fast-point
10 -10))
(define p10 (fast-point 20 -10))
(define p11 (fast-point -20 0))
(define p12 (fast-point -10 0))
(define p13 (fast-point 0 0))
(define p14 (fast-point 10 0))
(define p15 (fast-point 20 0))
(define p16 (fast-point -20 10))
(define p17 (fast-point -10 10))
(define p18 (fast-point 0 10))
(define p19 (fast-point 10
10))
(define p20 (fast-point 20
10))
(define p21 (fast-point -20 20))
(define p22 (fast-point -10 20))
(define p23 (fast-point 0 20))
(define p24 (fast-point 10
20))
(define p25 (fast-point 20
20))
(message "Test1 :")
(message "p1 in V1 ? ") (view ((V1 'punt-in?) p1))
(message "p2 in V1 ? ") (view ((V1 'punt-in?) p2))
(message "p3 in V1 ? ") (view ((V1 'punt-in?) p3))
(message "p4 in V1 ? ") (view ((V1 'punt-in?) p4))
(message "p5 in V1 ? ") (view ((V1 'punt-in?) p5))
(message "p6 in V1 ? ") (view ((V1
'punt-in?) p6))
(message "p7 in V1 ? ") (view ((V1 'punt-in?) p7))
(message "p8 in V1 ? ") (view ((V1 'punt-in?) p8))
(message "p9 in V1 ? ") (view ((V1 'punt-in?) p9))
(message "p10 in V1 ? ") (view ((V1 'punt-in?) p10))
(message "p11 in V1 ? ") (view ((V1
'punt-in?) p11))
(message "p12 in V1 ? ") (view ((V1 'punt-in?) p12))
(message "p13 in V1 ? ") (view ((V1 'punt-in?) p13))
(message "p14 in V1 ? ") (view ((V1 'punt-in?) p14))
(message "p15 in V1 ? ") (view ((V1 'punt-in?) p15))
(message "p16 in V1 ? ") (view ((V1
'punt-in?) p16))
(message "p17 in V1 ? ") (view ((V1 'punt-in?) p17))
(message "p18 in V1 ? ") (view ((V1 'punt-in?) p18))
(message "p19 in V1 ? ") (view ((V1 'punt-in?) p19))
(message "p20 in V1 ? ") (view ((V1 'punt-in?) p20))
(message "p21 in V1 ? ") (view ((V1
'punt-in?) p21))
(message "p22 in V1 ? ") (view ((V1 'punt-in?) p22))
(message "p23 in V1 ? ") (view ((V1 'punt-in?) p23))
(message "p24 in V1 ? ") (view ((V1 'punt-in?) p24))
(message "p25 in V1 ? ") (view ((V1 'punt-in?) p25))
;----------------------------
;test2 : gedraaide rechthoek
;-----------------------------
(message "Test 2")
(define V1
(make-graph-set
(fast-line -15 -10 -10 15)
(fast-line -10 15 15 10)
(fast-line 15 10 10 -15)
(fast-line 10 -15 -15 -10)))
(message "p1 in V1 ? ") (view ((V1
'punt-in?) p1))
(message "p2 in V1 ? ") (view ((V1 'punt-in?) p2))
(message "p3 in V1 ? ") (view ((V1 'punt-in?) p3))
(message "p4 in V1 ? ") (view ((V1 'punt-in?) p4))
(message "p5 in V1 ? ") (view ((V1 'punt-in?) p5))
(message "p6 in V1 ? ") (view ((V1
'punt-in?) p6))
(message "p7 in V1 ? ") (view ((V1 'punt-in?) p7))
(message "p8 in V1 ? ") (view ((V1 'punt-in?) p8))
(message "p9 in V1 ? ") (view ((V1 'punt-in?) p9))
(message "p10 in V1 ? ") (view ((V1 'punt-in?) p10))
(message "p11 in V1 ? ") (view ((V1
'punt-in?) p11))
(message "p12 in V1 ? ") (view ((V1 'punt-in?) p12))
(message "p13 in V1 ? ") (view ((V1 'punt-in?) p13))
(message "p14 in V1 ? ") (view ((V1 'punt-in?) p14))
(message "p15 in V1 ? ") (view ((V1 'punt-in?) p15))
(message "p16 in V1 ? ") (view ((V1
'punt-in?) p16))
(message "p17 in V1 ? ") (view ((V1 'punt-in?) p17))
(message "p18 in V1 ? ") (view ((V1 'punt-in?) p18))
(message "p19 in V1 ? ") (view ((V1 'punt-in?) p19))
(message "p20 in V1 ? ") (view ((V1 'punt-in?) p20))
(message "p21 in V1 ? ") (view ((V1
'punt-in?) p21))
(message "p22 in V1 ? ") (view ((V1 'punt-in?) p22))
(message "p23 in V1 ? ") (view ((V1 'punt-in?) p23))
(message "p24 in V1 ? ") (view ((V1 'punt-in?) p24))
(message "p25 in V1 ? ") (view ((V1 'punt-in?) p25))
Robot07.scm
Dit waren de test op het snijden
van cirkels
met lijnen en cirkels met cirkels. De test nummeren voort vanaf 7.
;-----------------------------------------------------
;test8 : testen van het snijden lijnen met een circle
;-----------------------------------------------------
(define (fast-circle x y r fa ta)
(make-circle (make-point x y) r fa
ta))
(define C1 (fast-circle 0 0
5 0 (/ PI 2)))
(define C2 (fast-circle 10 10 3 0 (* 2
PI)))
(define C3 (fast-circle 7 2
6 (/
PI 4) 3PI/2))
(define L1 (fast-line 5 17 5 0))
(define L2 (fast-line 9 12 9 -20))
(define L3 (fast-line 0 0 14 12))
(define L4 (fast-line 3 5 16 10))
(define L5 (fast-line 9.2426409 8.24640686 13.2426409 4.24640686))
(define L6 (fast-line 12 9 1 9))
(define L7 (fast-line 3 13 15 13))
(message "Test 8")
(crlf)
(message "L1 i C1") (view (intersect-l-c l1 C1))
(message "L2 i C1") (view (intersect-l-c l2 C1))
(message "L3 i C1") (view (intersect-l-c l3 C1))
(message "L4 i C1") (view (intersect-l-c l4 C1))
(message "L5 i C1") (view (intersect-l-c l5 C1))
(message "L6 i C1") (view (intersect-l-c l6 C1))
(message "L7 i C1") (view (intersect-l-c l7 C1))
(message "L1 i C2") (view
(intersect-l-c l1 C2))
(message "L2 i C2") (view (intersect-l-c l2 C2))
(message "L3 i C2") (view (intersect-l-c l3 C2))
(message "L4 i C2") (view (intersect-l-c l4 C2))
(message "L5 i C2") (view (intersect-l-c l5 C2))
(message "L6 i C2") (view (intersect-l-c l6 C2))
(message "L7 i C2") (view (intersect-l-c l7 C2))
(message "L1 i C3") (view
(intersect-l-c l1 C3))
(message "L2 i C3") (view (intersect-l-c l2 C3))
(message "L3 i C3") (view (intersect-l-c l3 C3))
(message "L4 i C3") (view (intersect-l-c l4 C3))
(message "L5 i C3") (view (intersect-l-c l5 C3))
(message "L6 i C3") (view (intersect-l-c l6 C3))
(message "L7 i C3") (view (intersect-l-c l7 C3))
;--------------------------------------------
;test9 : het snijden van circles met circles
;--------------------------------------------
(define C4 (fast-circle 0 0
5 0
2PI))
(define C5 (fast-circle 10 10 3 0 2PI))
(define C6 (fast-circle 7 2
6 0
2PI))
(message "Test 9")
(crlf)
(message "C1 i C1") (view (intersect-c-c C1 C1))
(message "C1 i C2") (view (intersect-c-c C1 C2))
(message "C1 i C3") (view (intersect-c-c C1 C3))
(message "C1 i C4") (view (intersect-c-c C1 C4))
(message "C1 i C5") (view (intersect-c-c C1 C5))
(message "C1 i C6") (view (intersect-c-c C1 C6))
(message "C2 i C1") (view
(intersect-c-c C2 C1))
(message "C2 i C2") (view (intersect-c-c C2 C2))
(message "C2 i C3") (view (intersect-c-c C2 C3))
(message "C2 i C4") (view (intersect-c-c C2 C4))
(message "C2 i C5") (view (intersect-c-c C2 C5))
(message "C2 i C6") (view (intersect-c-c C2 C6))
(message "C4 i C1") (view
(intersect-c-c C4 C1))
(message "C4 i C2") (view (intersect-c-c C4 C2))
(message "C4 i C3") (view (intersect-c-c C4 C3))
(message "C4 i C4") (view (intersect-c-c C4 C4))
(message "C4 i C5") (view (intersect-c-c C4 C5))
(message "C4 i C6") (view (intersect-c-c C4 C6))
(message "C5 i C1") (view
(intersect-c-c C5 C1))
(message "C5 i C2") (view (intersect-c-c C5 C2))
(message "C5 i C3") (view (intersect-c-c C5 C3))
(message "C5 i C4") (view (intersect-c-c C5 C4))
(message "C5 i C5") (view (intersect-c-c C5 C5))
(message "C5 i C6") (view (intersect-c-c C5 C6))
(message "C6 i C1") (view
(intersect-c-c C6 C1))
(message "C6 i C2") (view (intersect-c-c C6 C2))
(message "C6 i C3") (view (intersect-c-c C6 C3))
(message "C6 i C4") (view (intersect-c-c C6 C4))
(message "C6 i C5") (view (intersect-c-c C6 C5))
(message "C6 i C6") (view (intersect-c-c C6 C6))
Robot08.scm
Dit is nog eens het testen van de
punt-in?,
maar nu op een ingewikkeldere figuur.
;-------------------
;test3 : kasteeltje
;-------------------
(define (l-line lst)
(let ((s (make-graph-set)))
(define (loop prev cur)
(if (null? cur) s
(begin
((s 'add)
(make-line
(make-point (car prev)
(cdr prev))
(make-point (car (car
cur)) (cdr (car cur)))))
(loop (car cur) (cdr
cur)))))
(loop (car lst) (cdr lst))
s))
(define K (l-line
'(
(0 . 0)
(1 . 1)
(2 . 1)
(3 . 2)
(4 . 1)
(5 . 1)
(6 . 0)
(7 . 1)
(8 . 1)
(8 . 0)
(4 . 0)
(3 . 1)
(2 . 0)
(0 . 0)
)))
(define test-list
'(
(0 . 1)
(1 . 1)
(1.5 . 1)
(2 . 1)
(2.5 . 1)
(3 . 1)
(3.5 . 1)
(4 . 1 )
(4.5 . 1)
(5 . 1)
(6 . 1)
(7 . 1)
(7.5 . 1)
(8 . 1)
(9 . 1)
(1.5 . 0.5)
(3 . 0.5)
(4.5 . 0.5)
(6 . 0.5)
(7.5 . 0.5)
(9 . 0.5)
(0 . 0.5)
(3 . 0)
(9 . 0)
(1.5 . 1.5)
(3 . 1.5)
(6 . 1.5)
(5 . 2)
(1 . 2)
))
(define (test-program)
(define (loop lst)
(if (pair? lst)
(begin
(message
(car lst))
(message
" in K ? ")
(view
((K 'punt-in?)
(make-point (caar lst)
(cdar lst))))
(loop (cdr lst)))))
(loop test-list))
(test-program)
Robot10.scm
Hier zat een bug in
bij 100 10 10 10 23 10 10 10
(define (testje l1 l2 l3 l4 l5 l6 l7
l8)
(make-robot
(make-point 0 0)
(make-arm
l1
(make-arm
l1
(make-arm
l2
(make-arm
l2
(make-arm
l3
(make-arm
l3
(make-arm
l4
(make-arm
l4
(make-arm
l5
(make-arm
l5
(make-arm
l6
(make-arm
l6
(make-arm
l7
(make-arm
l7
(make-arm
l8
(make-arm
l8
null-component))))))))))))))))))
Robot12.scm
(define ralf-arm4 (make-arm 30
null-component))
(define ralf-arm3 (make-arm 20 ralf-arm4))
(define ralf-arm2 (make-arm 40 ralf-arm3))
(define ralf-arm1 (make-arm 80 ralf-arm2))
(define ralf
(make-robot
(make-point -150 30)
ralf-arm1))
(define dennis-arm (make-arm 50
null-component))
(define dennis
(make-robot
(make-point 0 0)
dennis-arm))
(define (move-to who speedx speedy)
((who 'right) (make-point speedx
speedy)))
(define (arm-length who new-length)
((who 'arm-length) new-length))
Robot13.scm
Dit is een test op
een T-stuk dat ik had gedefinieerd. Wat blijkt : PCS had te weinig
geheugen om
ermee overweg te kunnen.
(define ralf-pen1 (make-pen
'light-blue))
(define ralf-pen2 (make-pen 'light-blue))
(define ralf-pen3 (make-pen 'light-blue))
(define ralf-pen4 (make-pen 'light-blue))
(define ralf-arm4 (make-arm 10 0 ralf-pen4))
(define ralf-arm3 (make-arm 50 0 ralf-pen3))
(define ralf-arm2 (make-arm 100 0 ralf-pen2))
(define ralf-arm1 (make-arm 100 0 ralf-pen1))
(define ralf-T (make-T ralf-arm1 ralf-arm2 ralf-arm3 ralf-arm4))
(define ralf
(make-robot
(make-point -150 30)
0
ralf-T))
Robot16.scm
Het testen van de rotatie's.
(define circler-pen (make-pen 'BLUE))
(define circler-arm2 (make-arm 100 0 circler-pen))
(define circler-rot2 (make-scharnier PI/2 0 circler-arm2))
(define circler-arm1 (make-arm 100 0 circler-rot2))
(define circler-rot1 (make-scharnier PI/2 0 circler-arm1))
(define circler (make-robot (make-point 30 0) PI/2 circler-rot1))
(pen-down circler-pen)
Robot19.scm
Testen op de
boormachines.
(define boor-end (make-boor))
(define boormachien (make-robot (make-point 0 0) 0 boor-end))
(boor boor-end)
(rel-move boormachien 0 -100)
(boor boor-end)
(rel-move boormachien 0 200)
(boor boor-end)
(rel-move boormachien -100 -100)
(boor boor-end)
(rel-move boormachien 200 0)
(boor boor-end)
