Tarek Chaaban

Tarek Chaaban, M.Sc's official blog. It contains current web project portfolio, posts regarding his Canadian army experience, news, sports articles, and web tutorials on programming and using social networking technologies.

Scheme Programming Home Work

Scheme Programming Home Work

Scheme : Scheme is a statically scoped and properly tail-recursive dialect of the Lisp programming language invented by Guy Lewis Steele Jr. and Gerald Jay Sussman. It was designed to have an exceptionally clear and simple semantics and few different ways to form expressions. A wide variety of programming paradigms, including imperative, functional, and message passing styles, find convenient expression in Scheme.

This is the code source of our first Home Work That we had to do .

The Nice thing in scheme that those functions can be used again in any scheme program

; Programmer : Tarek Chaaban
; H-2006 Universite de Montreal.
; Functions for drawing in scheme using TCL/TK .

; ======================== First Part 1-a =============================

; Find The Distance between 2 points in scheme .

(define distance
(lambda (depart arrivee)
(abs (sqrt
(expt (- (vect-x arrivee) (vect-x depart)) 2)
(expt (- (vect-y arrivee) (vect-y depart)) 2))))))

;middle points of a vector x
(define middle-x
(lambda (depart arrivee)
(/ (+ (vect-x depart) (vect-x arrivee)) 2)))

;middle points of a vector y
(define middle-y
(lambda (depart arrivee)
(/ (+ (vect-y depart) (vect-y arrivee)) 2)))

; The exact middle point (x , y )
(define middle
(lambda (depart arrivee)
(vect (middle-x depart arrivee) (middle-y depart arrivee))))

; List of segments
(define ligne-lst
;;; segm, segm -> segment list
(lambda (depart arrivee)
(if (< (distance depart arrivee) 1/10)
(list (segm depart arrivee))
(ligne-lst depart (middle depart arrivee))
(ligne-lst (middle depart arrivee) arrivee)))))

; Show the line ... this call will draw a simple line from (x1 , y1) -> (x2 , y2)
(define ligne
(lambda (depart arrivee)
(lambda (test)
(test (ligne-lst depart arrivee)))))

; ========================= 1-b ==============================

; This function return a list of segments
(define parcours->dessinateur-aux
(lambda (lst)
(if (null? lst)
(if (eq? (pair? (vect-y lst)) #f)
(ligne-lst (vect-x lst)(segm-depart lst))
(parcours->dessinateur-aux (vect-y lst))

; Apply a transformation on the list of segment , this will be used later to apply rotation , translation
; loop , and reduction

(define parcours->dessinateur
(lambda (lst)
(lambda (transf)
(appliquer-transf (parcours->dessinateur-aux lst) transf))))

; The function that apply the transformation

(define appliquer-transf
(lambda (lst transf)
(if (null? lst)
(let ((lst2 (car lst)) (lst3 (cdr lst)))
(transf (segm-depart lst2))
(transf (segm-arrivee lst2)))
(appliquer-transf lst3 transf))

;————————— 1.c.translation ——————

(define trans
(lambda (dx dy seg)
(append (vect
(+ (vect-x seg) dx)
(+ (vect-y seg) dy)))))

(define trans2
(lambda (dx dy)
(lambda (lst)
(trans dx dy lst))))

(define translation (lambda (dx dy dessin)
(lambda (test)
(appliquer-transf (dessin (trans2 dx dy)) test))))

;————————— 1.c.reduction ——————

(define reduc
(lambda (dx dy seg)
(append (vect
(* (vect-x seg) dx)
(* (vect-y seg) dy)))))

(define reduc2
(lambda (dx dy)
(lambda (lst)
(reduc dx dy lst))))

(define reduction (lambda (dx dy dessin)
(lambda (test)
(appliquer-transf (dessin (reduc2 dx dy)) test))))

;————————— 1.c.rotation ——————
;1 degree = 0.0174532925 radians

(define rotat
(lambda (rad seg)
(let ((degree (* rad 0.0174532925)))
(append (vect
(+ (* (vect-x seg) (cos degree)) (* (vect-y seg)(sin degree)))
(- (* (vect-y seg) (cos degree)) (* (vect-x seg)(sin degree))))))))

(define rota2
(lambda (dx)
(lambda (lst)
(rotat dx lst))))

(define rotation (lambda (dx dessin)
(lambda (test)
(appliquer-transf (dessin (rota2 dx)) test))))

;————————— 1.c.loupe ——————
(define calcul-m (lambda (fact seg)
(+ 1 fact)
(+ 1 (* fact
(* (vect-x seg)(vect-x seg))
(* (vect-y seg)(vect-y seg))))))))

(define loupe-f
(lambda (fact seg)
(append (vect
(* (vect-x seg) (calcul-m fact seg))
(* (vect-y seg) (calcul-m fact seg))

(define loupe2
(lambda (dx)
(lambda (lst)
(loupe-f dx lst))))

(define loupe (lambda (dx dessin)
(lambda (test)
(appliquer-transf (dessin (loupe2 dx)) test))))

;————————— 1.d.superposition —————————
(define superposition
(lambda (dessin1 dessin2)
(lambda (test)
(appliquer-transf (combinaison dessin1 dessin2) test))))

(define combinaison (lambda (dessin1 dessin2)
(exctract-lst dessin2)
(exctract-lst dessin1))))

(define exctract-lst
(lambda (dessinateurs)
(dessinateurs (lambda (v) v))))

;—————————- 1.d.pile —————————————

; pile will put drawing on each other

(define pile (lambda (prop dessin1 dessin2)
(let ((x (- prop 1)) (y (- 1 prop)))
(translation 0 x (reduction 1 prop dessin1))
(translation 0 prop (reduction 1 y dessin2))))))

;—————————- 1.d.cote-a-cote —————————————

(define cote-a-cote (lambda (prop dessin1 dessin2)
(let ((x (- prop 1)) (y (- 1 prop)))
(translation x 0 (reduction prop 1 dessin1))
(translation prop 0 (reduction y 1 dessin2))))))

;————————– 2. entier -> dessinateur ———————
; This function take a number in parameter and draw the number

(define entier->dessinateur-liste (lambda (n)
(parcours->dessinateur (vector-ref parcours-pour-chiffres n))))

(define number->list-renverse (lambda (n)
(if (< n 10)
(cons n '())
(append (list (modulo n 10))(number->list-renverse (quotient n 10))))))

(define number->list (lambda (n)
(reverse (number->list-renverse n))))

(define list->number (lambda (lst)
(if (null? (cdr lst))
(car lst)
(+ (* (car lst) (expt 10 (- (length lst) 1)))
(list->number (cdr lst))))))

(define entier->dessinateur-aux (lambda (lst)
(if (and (= 1 (length lst)) (< (car lst) 10))
(cote-a-cote 1 (entier->dessinateur-liste (car lst)) vide)
(cote-a-cote (/ 1 (length lst))
(entier->dessinateur-aux (list (car lst)))
(entier->dessinateur-aux (cdr lst))))))

(define entier->dessinateur (lambda (n)
(entier->dessinateur-aux (number->list n))))

; elle sert a rien :) just pour avoir au moins utiliser la fonction foldr :p
(define tous-zero (lambda (lst)
(= 0 (foldr + 0 lst))))

;————————— #3 – Tree …….. ————————

; This function draw a tree … its called using a list and it give as a result a tree .
; example of call (dessiner (abre->dessinateur ‘(((1.3).(3.4)).((1.2).(3.4)))))
; this will draw a binary tree .

(define arbre->dessinateur (lambda (lst)
(if (pair? lst)
(pile (- 1 (/ 1 (length-arbre lst)))
(cote-a-cote 1/2
(arbre->dessinateur (car lst))
(arbre->dessinateur (cdr lst))) arbre)
; longueur de l’arbre en profondeur
(define length-arbre (lambda (arbre)
(if (pair? arbre)
(+ 1 (max (length-arbre (car arbre)) (length-arbre (cdr arbre))))

;—————————– Drawings definitions … ———————–
; the list of drawings
(define branche-gauche
(list (vect 0 1) (vect -1/2 -1))))

(define branche-droite
(list (vect 0 1)(vect 1/2 -1))))

(define arbre (superposition branche-droite branche-gauche))

(define line
(list (vect 0 1)(vect -1 -1))))

;dessiner un L
(define ell
(list (vect -1/2 1) (vect -1/2 -1) (vect 1/2 -1))))

;dessiner un triangle
(define triangle
(list (vect -1 -1) (vect 0 1) (vect 1 -1)(vect -1 -1))))

;Dessiner un losange
(define losange
(list (vect 0 1) (vect -1 0) (vect 0 -1) (vect 1 0)(vect 0 1))))

;Dessiner une courbe …
(define courbe
(list (vect -1 -1)(vect -1/2 0)(vect 0 1/2)(vect 1/2 0)(vect 1 -1))))

;vider l’ecran …
(define vide (parcours->dessinateur ‘()))

(define mix
(list (vect -1/2 1) (vect -1/2 -1) (vect 1/2 -1)(vect -1 -1) (vect 0 1) (vect 1 -1)(vect -1 -1))))


Results of some drawings :

Leave a Response

Please note: comment moderation is enabled and may delay your comment. There is no need to resubmit your comment.