Work transfer
This commit is contained in:
Felix Brendel
+190
-190
@@ -1,190 +1,190 @@
|
||||
(define-module ds
|
||||
:exports
|
||||
(alist::make alist::print alist::get alist::find alist::key-exists? alist::remove! alist::set! alist::set-overwrite!
|
||||
plist::make plist::print plist::get plist::find plist::prop-exists? plist::remove! plist::set! plist::set-overwrite!)
|
||||
|
||||
|
||||
(define-module alist
|
||||
:imports ("cxr.slime")
|
||||
:exports (make print get find key-exists? remove! set! set-overwrite!)
|
||||
(define key-not-found-index -1)
|
||||
|
||||
(define (make)
|
||||
(set-type!
|
||||
'(())
|
||||
:alist))
|
||||
|
||||
(define (print alist)
|
||||
(let ((associations (first alist)))
|
||||
(define (pprint-intern associations)
|
||||
(when associations
|
||||
(print " "
|
||||
(caar associations) "->"
|
||||
(cdar associations))
|
||||
(pprint-intern (rest associations))))
|
||||
(print "(")
|
||||
(when associations
|
||||
(print "\n")
|
||||
(pprint-intern associations))
|
||||
(print ")\n")))
|
||||
|
||||
|
||||
(define (get alist key)
|
||||
(let ((associations (first alist)))
|
||||
(define (alist-get-intern associations key)
|
||||
(cond ((null? associations)
|
||||
(error :key-not-found "key was not found in alist"))
|
||||
((= (caar associations) key)
|
||||
(cdar associations))
|
||||
(else (alist-get-intern (rest associations) key))))
|
||||
(alist-get-intern associations key)))
|
||||
|
||||
|
||||
(define (find alist key)
|
||||
(let ((associations (first alist)))
|
||||
(define (alist-find-intern associations key current-index)
|
||||
(cond ((null? associations) key-not-found-index)
|
||||
((= (caar associations) key) current-index)
|
||||
(else (alist-find-intern (rest associations)
|
||||
key
|
||||
(+ 1 current-index)))))
|
||||
(alist-find-intern associations key 0)))
|
||||
|
||||
|
||||
(define (key-exists? alist key)
|
||||
(not (= (find alist key)
|
||||
key-not-found-index)))
|
||||
|
||||
|
||||
(define (remove! alist key)
|
||||
(let ((index (find alist key)))
|
||||
(define (alist-remove!-internal asociations index)
|
||||
;; reminder: we only get called if we are not replacing the
|
||||
;; first element in the alist
|
||||
;; reminder2: we know that the key exists
|
||||
(if (= index 1)
|
||||
;; we want to remove the next one, so we set our
|
||||
;; cdr to the next next one
|
||||
(mutate associations (pair (first associations)
|
||||
(rest (rest associations))))
|
||||
;; else cdr-recurse
|
||||
(alist-remove!-internal (rest asociations) (- index 1))))
|
||||
|
||||
(cond ((= index key-not-found-index) (error :key-not-found "key to remove was not found"))
|
||||
((= index 0) (mutate alist (pair (cdar alist) ())))
|
||||
(else (alist-remove!-internal alist index))))
|
||||
alist)
|
||||
|
||||
|
||||
(define (set! alist key value)
|
||||
(mutate alist (set-type! (pair (pair (pair key value)
|
||||
(car alist))
|
||||
())
|
||||
:alist)))
|
||||
|
||||
(define (set-overwrite! alist key value)
|
||||
(let ((associations (first alist)))
|
||||
(define (alist-set-overwrite-intern associations key value)
|
||||
(cond ((= (caar associations) key)
|
||||
(mutate (car associations) (pair key value)))
|
||||
((null? associations) (set! alist key value))
|
||||
(else (alist-set-overwrite-intern
|
||||
(rest associations) key value))))
|
||||
(alist-set-overwrite-intern associations key value))
|
||||
alist)
|
||||
)
|
||||
|
||||
(define-module plist
|
||||
:imports ("cxr.slime")
|
||||
:exports (make print get find prop-exists? remove! set! set-overwrite!)
|
||||
;; plist:
|
||||
;; [ |/]
|
||||
;; |
|
||||
;; V
|
||||
;; [ | ]------------->[ | ]-------------> ...
|
||||
;; | |
|
||||
;; V V
|
||||
;; :key1 value1
|
||||
;;
|
||||
;; '((:key1 value1 :key2 value2))
|
||||
|
||||
(define key-not-found-index -1)
|
||||
|
||||
(define (make)
|
||||
(set-type!
|
||||
'(())
|
||||
:plist))
|
||||
|
||||
(define (print plist)
|
||||
(let ((props (first plist)))
|
||||
(define (pprint-intern props)
|
||||
(when props
|
||||
(print " "
|
||||
(car props) "->"
|
||||
(cadr props))
|
||||
(pprint-intern (cddr props))))
|
||||
(print "(")
|
||||
(when props
|
||||
(print "\n")
|
||||
(pprint-intern props))
|
||||
(print ")\n")))
|
||||
|
||||
(define (get plist prop)
|
||||
(let ((props (first plist)))
|
||||
(define (plist-get-intern props prop)
|
||||
(cond ((null? props)
|
||||
(error :key-not-found "property was not found in plist"))
|
||||
((= (car props) prop)
|
||||
(cadr props))
|
||||
(else (plist-get-intern (cddr props) prop))))
|
||||
(plist-get-intern props prop)))
|
||||
|
||||
(define (set! plist prop value)
|
||||
(mutate plist (set-type! (pair (pair prop (pair value (first plist))) ())
|
||||
:plist)))
|
||||
|
||||
(define (set-overwrite! plist prop value)
|
||||
(let ((props (first plist)))
|
||||
(define (plist-set-overwrite-intern props prop value)
|
||||
(cond ((= (car props) prop)
|
||||
(mutate (cdr props) (pair value (cddr props))))
|
||||
((null? props) (plist-set! plist prop value))
|
||||
(else (plist-set-overwrite-intern
|
||||
(cddr props) prop value))))
|
||||
(plist-set-overwrite-intern props prop value))
|
||||
plist)
|
||||
|
||||
(define (find plist prop)
|
||||
(let ((props (first plist)))
|
||||
(define (plist-find-intern props prop current-index)
|
||||
(cond ((null? props) key-not-found-index)
|
||||
((= (car props) prop) current-index)
|
||||
(else (plist-find-intern (cddr props) prop
|
||||
(+ 1 current-index)))))
|
||||
(plist-find-intern props prop 0)))
|
||||
|
||||
(define (prop-exists? plist prop)
|
||||
(not (= (find plist prop)
|
||||
key-not-found-index)))
|
||||
|
||||
(define (remove! plist prop)
|
||||
(let ((index (find plist prop)))
|
||||
(define (plist-remove!-internal props index)
|
||||
;; reminder: we only get called if we are not replacing the
|
||||
;; first element in the alist
|
||||
;; reminder2: we know that the key exists
|
||||
(if (= index 1)
|
||||
;; we want to remove the next one, so we set our
|
||||
;; cdr to the next next one
|
||||
(mutate (cdar props) (pair (cadar props) ;; xD nice meme dude!!!
|
||||
(cdr (cdr (cdr (cdar props))))))
|
||||
;; else cdr-recurse
|
||||
(plist-remove!-internal (cddr props) (- index 1))))
|
||||
|
||||
(cond ((= index key-not-found-index) (error :key-not-found "prop to remove was not found"))
|
||||
((= index 0) (mutate plist (pair (cddar plist) ())))
|
||||
(else (plist-remove!-internal plist index))))
|
||||
plist)
|
||||
|
||||
)
|
||||
)
|
||||
(define-module ds
|
||||
:exports
|
||||
(alist::make alist::print alist::get alist::find alist::key-exists? alist::remove! alist::set! alist::set-overwrite!
|
||||
plist::make plist::print plist::get plist::find plist::prop-exists? plist::remove! plist::set! plist::set-overwrite!)
|
||||
|
||||
|
||||
(define-module alist
|
||||
:imports ("cxr.slime")
|
||||
:exports (make print get find key-exists? remove! set! set-overwrite!)
|
||||
(define key-not-found-index -1)
|
||||
|
||||
(define (make)
|
||||
(set-type!
|
||||
'(())
|
||||
:alist))
|
||||
|
||||
(define (print alist)
|
||||
(let ((associations (first alist)))
|
||||
(define (pprint-intern associations)
|
||||
(when associations
|
||||
(print " "
|
||||
(caar associations) "->"
|
||||
(cdar associations))
|
||||
(pprint-intern (rest associations))))
|
||||
(print "(")
|
||||
(when associations
|
||||
(print "\n")
|
||||
(pprint-intern associations))
|
||||
(print ")\n")))
|
||||
|
||||
|
||||
(define (get alist key)
|
||||
(let ((associations (first alist)))
|
||||
(define (alist-get-intern associations key)
|
||||
(cond ((null? associations)
|
||||
(error :key-not-found "key was not found in alist"))
|
||||
((= (caar associations) key)
|
||||
(cdar associations))
|
||||
(else (alist-get-intern (rest associations) key))))
|
||||
(alist-get-intern associations key)))
|
||||
|
||||
|
||||
(define (find alist key)
|
||||
(let ((associations (first alist)))
|
||||
(define (alist-find-intern associations key current-index)
|
||||
(cond ((null? associations) key-not-found-index)
|
||||
((= (caar associations) key) current-index)
|
||||
(else (alist-find-intern (rest associations)
|
||||
key
|
||||
(+ 1 current-index)))))
|
||||
(alist-find-intern associations key 0)))
|
||||
|
||||
|
||||
(define (key-exists? alist key)
|
||||
(not (= (find alist key)
|
||||
key-not-found-index)))
|
||||
|
||||
|
||||
(define (remove! alist key)
|
||||
(let ((index (find alist key)))
|
||||
(define (alist-remove!-internal asociations index)
|
||||
;; reminder: we only get called if we are not replacing the
|
||||
;; first element in the alist
|
||||
;; reminder2: we know that the key exists
|
||||
(if (= index 1)
|
||||
;; we want to remove the next one, so we set our
|
||||
;; cdr to the next next one
|
||||
(mutate associations (pair (first associations)
|
||||
(rest (rest associations))))
|
||||
;; else cdr-recurse
|
||||
(alist-remove!-internal (rest asociations) (- index 1))))
|
||||
|
||||
(cond ((= index key-not-found-index) (error :key-not-found "key to remove was not found"))
|
||||
((= index 0) (mutate alist (pair (cdar alist) ())))
|
||||
(else (alist-remove!-internal alist index))))
|
||||
alist)
|
||||
|
||||
|
||||
(define (set! alist key value)
|
||||
(mutate alist (set-type! (pair (pair (pair key value)
|
||||
(car alist))
|
||||
())
|
||||
:alist)))
|
||||
|
||||
(define (set-overwrite! alist key value)
|
||||
(let ((associations (first alist)))
|
||||
(define (alist-set-overwrite-intern associations key value)
|
||||
(cond ((= (caar associations) key)
|
||||
(mutate (car associations) (pair key value)))
|
||||
((null? associations) (set! alist key value))
|
||||
(else (alist-set-overwrite-intern
|
||||
(rest associations) key value))))
|
||||
(alist-set-overwrite-intern associations key value))
|
||||
alist)
|
||||
)
|
||||
|
||||
(define-module plist
|
||||
:imports ("cxr.slime")
|
||||
:exports (make print get find prop-exists? remove! set! set-overwrite!)
|
||||
;; plist:
|
||||
;; [ |/]
|
||||
;; |
|
||||
;; V
|
||||
;; [ | ]------------->[ | ]-------------> ...
|
||||
;; | |
|
||||
;; V V
|
||||
;; :key1 value1
|
||||
;;
|
||||
;; '((:key1 value1 :key2 value2))
|
||||
|
||||
(define key-not-found-index -1)
|
||||
|
||||
(define (make)
|
||||
(set-type!
|
||||
'(())
|
||||
:plist))
|
||||
|
||||
(define (print plist)
|
||||
(let ((props (first plist)))
|
||||
(define (pprint-intern props)
|
||||
(when props
|
||||
(print " "
|
||||
(car props) "->"
|
||||
(cadr props))
|
||||
(pprint-intern (cddr props))))
|
||||
(print "(")
|
||||
(when props
|
||||
(print "\n")
|
||||
(pprint-intern props))
|
||||
(print ")\n")))
|
||||
|
||||
(define (get plist prop)
|
||||
(let ((props (first plist)))
|
||||
(define (plist-get-intern props prop)
|
||||
(cond ((null? props)
|
||||
(error :key-not-found "property was not found in plist"))
|
||||
((= (car props) prop)
|
||||
(cadr props))
|
||||
(else (plist-get-intern (cddr props) prop))))
|
||||
(plist-get-intern props prop)))
|
||||
|
||||
(define (set! plist prop value)
|
||||
(mutate plist (set-type! (pair (pair prop (pair value (first plist))) ())
|
||||
:plist)))
|
||||
|
||||
(define (set-overwrite! plist prop value)
|
||||
(let ((props (first plist)))
|
||||
(define (plist-set-overwrite-intern props prop value)
|
||||
(cond ((= (car props) prop)
|
||||
(mutate (cdr props) (pair value (cddr props))))
|
||||
((null? props) (plist-set! plist prop value))
|
||||
(else (plist-set-overwrite-intern
|
||||
(cddr props) prop value))))
|
||||
(plist-set-overwrite-intern props prop value))
|
||||
plist)
|
||||
|
||||
(define (find plist prop)
|
||||
(let ((props (first plist)))
|
||||
(define (plist-find-intern props prop current-index)
|
||||
(cond ((null? props) key-not-found-index)
|
||||
((= (car props) prop) current-index)
|
||||
(else (plist-find-intern (cddr props) prop
|
||||
(+ 1 current-index)))))
|
||||
(plist-find-intern props prop 0)))
|
||||
|
||||
(define (prop-exists? plist prop)
|
||||
(not (= (find plist prop)
|
||||
key-not-found-index)))
|
||||
|
||||
(define (remove! plist prop)
|
||||
(let ((index (find plist prop)))
|
||||
(define (plist-remove!-internal props index)
|
||||
;; reminder: we only get called if we are not replacing the
|
||||
;; first element in the alist
|
||||
;; reminder2: we know that the key exists
|
||||
(if (= index 1)
|
||||
;; we want to remove the next one, so we set our
|
||||
;; cdr to the next next one
|
||||
(mutate (cdar props) (pair (cadar props) ;; xD nice meme dude!!!
|
||||
(cdr (cdr (cdr (cdar props))))))
|
||||
;; else cdr-recurse
|
||||
(plist-remove!-internal (cddr props) (- index 1))))
|
||||
|
||||
(cond ((= index key-not-found-index) (error :key-not-found "prop to remove was not found"))
|
||||
((= index 0) (mutate plist (pair (cddar plist) ())))
|
||||
(else (plist-remove!-internal plist index))))
|
||||
plist)
|
||||
|
||||
)
|
||||
)
|
||||
|
||||
+12
-12
@@ -1,12 +1,12 @@
|
||||
(define-module automata
|
||||
:imports ("sets.slime")
|
||||
:exports (make-dfa)
|
||||
|
||||
(define (make-dfa Q S delta q0 F)
|
||||
(let ((q q0))
|
||||
(set-type! (lambda (s)
|
||||
(set! q (delta q s))
|
||||
(list (if (set::contains? F q) :accept :fail) q))
|
||||
:automaton)))
|
||||
|
||||
)
|
||||
(define-module automata
|
||||
:imports ("sets.slime")
|
||||
:exports (make-dfa)
|
||||
|
||||
(define (make-dfa Q S delta q0 F)
|
||||
(let ((q q0))
|
||||
(set-type! (lambda (s)
|
||||
(set! q (delta q s))
|
||||
(list (if (set::contains? F q) :accept :fail) q))
|
||||
:automaton)))
|
||||
|
||||
)
|
||||
|
||||
+3831
-3831
File diff suppressed because it is too large
Load Diff
@@ -1,8 +1,8 @@
|
||||
(import "alist.slime")
|
||||
(import "automata.slime")
|
||||
(import "interpolation.slime")
|
||||
(import "oo.slime")
|
||||
(import "math.slime")
|
||||
(import "sets.slime")
|
||||
|
||||
(generate-docs "../manual/built-in-docs.org")
|
||||
(import "alist.slime")
|
||||
(import "automata.slime")
|
||||
(import "interpolation.slime")
|
||||
(import "oo.slime")
|
||||
(import "math.slime")
|
||||
(import "sets.slime")
|
||||
|
||||
(generate-docs "../manual/built-in-docs.org")
|
||||
|
||||
+45
-45
@@ -1,45 +1,45 @@
|
||||
|
||||
(define-module interpolation
|
||||
:exports (lerp lerper stepped-lerper
|
||||
point-lerp point-lerper
|
||||
bezier2 bezierer2)
|
||||
|
||||
(define-typed (lerp a :number b :number t :number)
|
||||
(+ (* t (- b a)) a))
|
||||
|
||||
(define-typed (lerper a :number b :number)
|
||||
(define-typed (ret t :number)
|
||||
(lerp a b t))
|
||||
ret)
|
||||
|
||||
(define-typed (stepped-lerper a :number b :number #steps :number)
|
||||
(let ((t 0)
|
||||
(dt (/ 1 #steps)))
|
||||
(lambda ()
|
||||
(let ((res (lerp a b t)))
|
||||
(mutate t (+ t dt))
|
||||
res))))
|
||||
|
||||
(define make-point pair)
|
||||
(define point->x first)
|
||||
(define point->y rest)
|
||||
|
||||
(define (point-lerp p1 p2 t)
|
||||
(make-point (lerp (point->x p1) (point->x p2) t)
|
||||
(lerp (point->y p1) (point->y p2) t)))
|
||||
|
||||
(define (point-lerper p1 p2)
|
||||
(lambda (t) (point-lerp p1 p2 t)))
|
||||
|
||||
(define (bezier2 p1 p2 p3 t)
|
||||
(point-lerp (point-lerp p1 p2 t)
|
||||
(point-lerp p2 p3 t)
|
||||
t))
|
||||
|
||||
(define (bezierer2 p1 p2 p3)
|
||||
(let ((lerper1 (point-lerper p1 p2))
|
||||
(lerper2 (point-lerper p2 p3)))
|
||||
(lambda (t)
|
||||
(point-lerp (lerper1 t)
|
||||
(lerper2 t) t))))
|
||||
)
|
||||
|
||||
(define-module interpolation
|
||||
:exports (lerp lerper stepped-lerper
|
||||
point-lerp point-lerper
|
||||
bezier2 bezierer2)
|
||||
|
||||
(define-typed (lerp a :number b :number t :number)
|
||||
(+ (* t (- b a)) a))
|
||||
|
||||
(define-typed (lerper a :number b :number)
|
||||
(define-typed (ret t :number)
|
||||
(lerp a b t))
|
||||
ret)
|
||||
|
||||
(define-typed (stepped-lerper a :number b :number #steps :number)
|
||||
(let ((t 0)
|
||||
(dt (/ 1 #steps)))
|
||||
(lambda ()
|
||||
(let ((res (lerp a b t)))
|
||||
(mutate t (+ t dt))
|
||||
res))))
|
||||
|
||||
(define make-point pair)
|
||||
(define point->x first)
|
||||
(define point->y rest)
|
||||
|
||||
(define (point-lerp p1 p2 t)
|
||||
(make-point (lerp (point->x p1) (point->x p2) t)
|
||||
(lerp (point->y p1) (point->y p2) t)))
|
||||
|
||||
(define (point-lerper p1 p2)
|
||||
(lambda (t) (point-lerp p1 p2 t)))
|
||||
|
||||
(define (bezier2 p1 p2 p3 t)
|
||||
(point-lerp (point-lerp p1 p2 t)
|
||||
(point-lerp p2 p3 t)
|
||||
t))
|
||||
|
||||
(define (bezierer2 p1 p2 p3)
|
||||
(let ((lerper1 (point-lerper p1 p2))
|
||||
(lerper2 (point-lerper p2 p3)))
|
||||
(lambda (t)
|
||||
(point-lerp (lerper1 t)
|
||||
(lerper2 t) t))))
|
||||
)
|
||||
|
||||
+60
-60
@@ -1,60 +1,60 @@
|
||||
(define-module math
|
||||
:imports ("oo.slime")
|
||||
:exports (pi abs sqrt make-vector3)
|
||||
|
||||
(define pi
|
||||
:doc "Tha famous circle constant."
|
||||
3.14159265)
|
||||
|
||||
(define (abs x)
|
||||
:doc "Accepts one argument and returns the absoulte value of it"
|
||||
(if (> x 0) x (- x)))
|
||||
|
||||
(define (sqrt x)
|
||||
:doc "Accepts one argument and returns the square root of it"
|
||||
(** x 0.5))
|
||||
|
||||
(define-class (vector3 x y z)
|
||||
(define (set-x new-x) (mutate x new-x))
|
||||
(define (set-y new-y) (mutate y new-y))
|
||||
(define (set-z new-z) (mutate z new-z))
|
||||
|
||||
(define (length)
|
||||
(** (+ (* x x) (* y y) (* z z)) 0.5))
|
||||
|
||||
(define (scale fac)
|
||||
(mutate x (* fac x))
|
||||
(mutate y (* fac y))
|
||||
(mutate z (* fac z))
|
||||
fac)
|
||||
|
||||
(define (add other)
|
||||
(make-vector3
|
||||
(+ (-> other x) x)
|
||||
(+ (-> other y) y)
|
||||
(+ (-> other z) z)))
|
||||
|
||||
(define (subtract other)
|
||||
(make-vector3
|
||||
(- (-> other x) x)
|
||||
(- (-> other y) y)
|
||||
(- (-> other z) z)))
|
||||
|
||||
(define (equal? other)
|
||||
(and (= (-> other x) x)
|
||||
(= (-> other y) y)
|
||||
(= (-> other z) z)))
|
||||
|
||||
(define (scalar-product other)
|
||||
(+ (* (-> other x) x)
|
||||
(* (-> other y) y)
|
||||
(* (-> other z) z)))
|
||||
|
||||
(define (cross-product other)
|
||||
(make-vector3
|
||||
(- (* (-> other z) y) (* (-> other y) z))
|
||||
(- (* (-> other x) z) (* (-> other z) x))
|
||||
(- (* (-> other y) x) (* (-> other x) y))))
|
||||
|
||||
(define (print)
|
||||
(print :sep "" "[vector3] (" x " " y " " z ")"))))
|
||||
(define-module math
|
||||
:imports ("oo.slime")
|
||||
:exports (pi abs sqrt make-vector3)
|
||||
|
||||
(define pi
|
||||
:doc "Tha famous circle constant."
|
||||
3.14159265)
|
||||
|
||||
(define (abs x)
|
||||
:doc "Accepts one argument and returns the absoulte value of it"
|
||||
(if (> x 0) x (- x)))
|
||||
|
||||
(define (sqrt x)
|
||||
:doc "Accepts one argument and returns the square root of it"
|
||||
(** x 0.5))
|
||||
|
||||
(define-class (vector3 x y z)
|
||||
(define (set-x new-x) (mutate x new-x))
|
||||
(define (set-y new-y) (mutate y new-y))
|
||||
(define (set-z new-z) (mutate z new-z))
|
||||
|
||||
(define (length)
|
||||
(** (+ (* x x) (* y y) (* z z)) 0.5))
|
||||
|
||||
(define (scale fac)
|
||||
(mutate x (* fac x))
|
||||
(mutate y (* fac y))
|
||||
(mutate z (* fac z))
|
||||
fac)
|
||||
|
||||
(define (add other)
|
||||
(make-vector3
|
||||
(+ (-> other x) x)
|
||||
(+ (-> other y) y)
|
||||
(+ (-> other z) z)))
|
||||
|
||||
(define (subtract other)
|
||||
(make-vector3
|
||||
(- (-> other x) x)
|
||||
(- (-> other y) y)
|
||||
(- (-> other z) z)))
|
||||
|
||||
(define (equal? other)
|
||||
(and (= (-> other x) x)
|
||||
(= (-> other y) y)
|
||||
(= (-> other z) z)))
|
||||
|
||||
(define (scalar-product other)
|
||||
(+ (* (-> other x) x)
|
||||
(* (-> other y) y)
|
||||
(* (-> other z) z)))
|
||||
|
||||
(define (cross-product other)
|
||||
(make-vector3
|
||||
(- (* (-> other z) y) (* (-> other y) z))
|
||||
(- (* (-> other x) z) (* (-> other z) x))
|
||||
(- (* (-> other y) x) (* (-> other x) y))))
|
||||
|
||||
(define (print)
|
||||
(print :sep "" "[vector3] (" x " " y " " z ")"))))
|
||||
|
||||
+25
-25
@@ -1,25 +1,25 @@
|
||||
(define-syntax (define-class name-and-members . body)
|
||||
"Macro for creating simple classes."
|
||||
(let ((name (first name-and-members))
|
||||
(members (rest name-and-members)))
|
||||
`(set-type!
|
||||
(define
|
||||
;; The function definition
|
||||
(,(string->symbol (concat-strings "make-" (symbol->string name))) ,@members)
|
||||
;; The docstring
|
||||
,(concat-strings "This is the handle to an object of the class " (symbol->string name))
|
||||
;; the body
|
||||
,@body
|
||||
(let ,(zip members members)
|
||||
(set-type!
|
||||
(lambda args
|
||||
"This is the docs for the handle"
|
||||
(let ((op (eval (first args))))
|
||||
(if (procedure? op)
|
||||
(eval args)
|
||||
(eval (first args)))))
|
||||
,(symbol->keyword name))))
|
||||
:constructor)))
|
||||
|
||||
(define-syntax (-> obj meth . args)
|
||||
`(,obj ',meth ,@args))
|
||||
(define-syntax (define-class name-and-members . body)
|
||||
"Macro for creating simple classes."
|
||||
(let ((name (first name-and-members))
|
||||
(members (rest name-and-members)))
|
||||
`(set-type!
|
||||
(define
|
||||
;; The function definition
|
||||
(,(string->symbol (concat-strings "make-" (symbol->string name))) ,@members)
|
||||
;; The docstring
|
||||
,(concat-strings "This is the handle to an object of the class " (symbol->string name))
|
||||
;; the body
|
||||
,@body
|
||||
(let ,(zip members members)
|
||||
(set-type!
|
||||
(lambda args
|
||||
"This is the docs for the handle"
|
||||
(let ((op (eval (first args))))
|
||||
(if (procedure? op)
|
||||
(eval args)
|
||||
(eval (first args)))))
|
||||
,(symbol->keyword name))))
|
||||
:constructor)))
|
||||
|
||||
(define-syntax (-> obj meth . args)
|
||||
`(,obj ',meth ,@args))
|
||||
|
||||
+507
-508
File diff suppressed because it is too large
Load Diff
+106
-106
@@ -1,106 +1,106 @@
|
||||
(define hm/set! hash-map-set!)
|
||||
|
||||
(define hm/get hash-map-get)
|
||||
|
||||
(define (hm/get-or-nil hm key) (mytry (hm/get hm key) ()))
|
||||
|
||||
(define-syntax (pe expr) `(print ',expr "evaluates to" ,expr))
|
||||
|
||||
(define the-empty-stream ())
|
||||
|
||||
(define (stream-null? s) (if s t ()))
|
||||
|
||||
(define-syntax (delay expr) `(,lambda () ,expr))
|
||||
|
||||
(define (force promise) (promise))
|
||||
|
||||
(define-syntax (when condition . body) :doc "Special form for when multiple actions should be done if a\ncondition is true.\n\n{{{example_start}}}\n(when (not ())\n (print "Hello ")\n (print "from ")\n (print "when!"))\n\n(when ()\n (print "Goodbye ")\n (print "World!"))\n{{{example_end}}}\n" (if (= (rest body) ()) `(if ,condition ,@body nil) `(if ,condition (begin ,@body) nil)))
|
||||
|
||||
(define-syntax (unless condition . body) :doc "Special form for when multiple actions should be done if a\ncondition is false." (if (= (rest body) ()) `(if ,condition nil ,@body) `(if ,condition nil (begin ,@body))))
|
||||
|
||||
(define-syntax (n-times times action) :doc "Executes action times times." (define (repeat times elem) (unless (> 1 times) (pair elem (repeat (- times 1) elem)))) `(begin ,@(repeat times action)))
|
||||
|
||||
(define-syntax (let bindings . body) (define (unzip lists) (when lists (define (iter lists l1 l2) (define elem (first lists)) (if elem (iter (rest lists) (pair (first elem) l1) (pair (first (rest elem)) l2)) (list l1 l2)))) (iter lists () ())) (define unzipped (unzip bindings)) `((,lambda ,(first unzipped) ,@body) ,@(first (rest unzipped))))
|
||||
|
||||
(define-syntax (cond . clauses) (define (rec clauses) (if (= nil clauses) nil (if (= (first (first clauses)) 'else) (begin (if (not (= (rest clauses) ())) (error :syntax-error "There are additional clauses after the else clause!") (pair 'begin (rest (first clauses))))) `(if ,(first (first clauses)) (begin ,@(rest (first clauses))) ,(rec (rest clauses)))))) (rec clauses))
|
||||
|
||||
(define-syntax (case var . clauses) (define (rec clauses) (if (= nil clauses) nil (if (= (first (first clauses)) 'else) (begin (if (not (= (rest clauses) ())) (error :syntax-error "There are additional clauses after the else clause!") (pair 'begin (rest (first clauses))))) `(if (member? ,var ',(first (first clauses))) (begin ,@(rest (first clauses))) ,(rec (rest clauses)))))) (rec clauses))
|
||||
|
||||
(define-syntax (construct-list . body) :doc "\n{{{example_start}}}\n(construct-list\n i <- '(1 2 3 4 5)\n yield (* i i))\n{{{example_end}}}\n\n(construct-list\n i <- '(1 2 3 4)\n j <- '(A B)\n yield (pair i j))\n\n(construct-list\n i <- '(1 2 3 4 5 6 7 8)\n if (= 0 (% i 2))\n yield i)\n" (define (append-map f ll) (unless (= ll ()) (define val (f (first ll))) (if (= (first val) ()) (append-map f (rest ll)) (extend val (append-map f (rest ll)))))) (define (rec body) (cond ((= () body) ()) ((= () (rest body)) (first body)) ((= (first (rest body)) '<-) `(,append-map (lambda (,(first body)) (list ,(rec (rest (rest (rest body)))))) ,(first (rest (rest body))))) ((= (first body) 'if) `(when ,(first (rest body)) ,(rec (rest (rest body))))) ((= (first (rest body)) 'yield) (first (rest body))) (else (error :syntax-error "Not a do-able expression")))) (rec body))
|
||||
|
||||
(define-syntax (define-typed args . body) (define (get-arg-names args) (when args (pair (first args) (get-arg-names (rest (rest args)))))) (let ((name (first args)) (lambda-list (rest args)) (arg-names (get-arg-names (rest args)))) `(define (,name ,@arg-names) (assert-types= ,@lambda-list) ,@body)))
|
||||
|
||||
(define-syntax (define-module module-name (:imports ()) :exports . body) (let ((module-prefix (concat-strings (symbol->string module-name) "::"))) (eval `(begin ,@(map (lambda (x) `(,import ,x)) imports) ,@body)) (pair 'begin (map (lambda (orig-export-name) (let ((export-name (string->symbol (concat-strings module-prefix (symbol->string orig-export-name))))) `(define ,export-name ,(mytry (eval orig-export-name) (error :module-error "The module does not contain a key it tries to export"))))) exports))))
|
||||
|
||||
(define-syntax (generic-extend args . body) (let ((fun-name (first args)) (params (rest args)) (types ()) (names ())) (define (process-params params) (when params (let ((_name (first params)) (_type (first (rest params)))) (assert (symbol? _name)) (assert (keyword? _type)) (set! types (append types _type)) (set! names (append names _name)) (process-params (rest (rest params)))))) (process-params params) (let ((generic-map-name (string->symbol (concat-strings "generic-" (symbol->string fun-name) "-map")))) (unless (bound? generic-map-name) (define generic-map-name (hash-map))) (hm/set! generic-map-name types (eval `(,lambda ,names ,@body))) (if (bound? fun-name) (let ((exisiting-fun (eval fun-name))) (unless (type=? exisiting-fun :generic-procedure) (unless (procedure? exisiting-fun) (error :macro-expand-error "can only generic-extend procedures.")) (define orig-proc exisiting-fun) (define fun-name (eval `(,lambda args (let ((fun (hm/get (map type args)))) (if (procedure? fun) (fun . args) (,orig-proc . args))))))))))))
|
||||
|
||||
(define (null? x) :doc "Checks if the argument is =nil=." (= x ()))
|
||||
|
||||
(define (type=? obj typ) :doc "Checks if the argument =obj= is of type =typ=" (= (type obj) typ))
|
||||
|
||||
(define (types=? . objs) (define (inner objs) (if objs (let ((actual-type (type (first objs))) (desired-type (first (rest objs)))) (if (= actual-type desired-type) (inner (rest (rest objs))) ())) t)) (inner objs))
|
||||
|
||||
(define (assert-types= . objs) (define (inner objs) (when objs (let ((actual-type (type (first objs))) (desired-type (first (rest objs)))) (if (= actual-type desired-type) (inner (rest (rest objs))) (error :type-missmatch "type missmatch" actual-type desired-type))))) (inner objs))
|
||||
|
||||
(define (number? x) :doc "Checks if the argument is a number." (type=? x :number))
|
||||
|
||||
(define (symbol? x) :doc "Checks if the argument is a symbol." (type=? x :symbol))
|
||||
|
||||
(define (keyword? x) :doc "Checks if the argument is a keyword." (type=? x :keyword))
|
||||
|
||||
(define (pair? x) :doc "Checks if the argument is a pair." (type=? x :pair))
|
||||
|
||||
(define (string? x) :doc "Checks if the argument is a string." (type=? x :string))
|
||||
|
||||
(define (lambda? x) :doc "Checks if the argument is a function." (type=? x :lambda))
|
||||
|
||||
(define (macro? x) :doc "Checks if the argument is a macro." (type=? x :macro))
|
||||
|
||||
(define (special-lambda? x) :doc "Checks if the argument is a special-lambda." (type=? x :dynamic-macro))
|
||||
|
||||
(define (built-in-function? x) :doc "Checks if the argument is a built-in function." (type=? x :cfunction))
|
||||
|
||||
(define (continuation? x) :doc "Checks if the argument is a continuation." (type=? x :continuation))
|
||||
|
||||
(define (procedure? x) (or (lambda? x) (special-lambda? x) (macro? x) (built-in-function? x) (continuation? x)))
|
||||
|
||||
(define (end seq) :doc "Returns the last pair in the sqeuence.\n\n{{{example_start}}}\n(define a (list 1 2 3 4))\n(print (end a))\n{{{example_end}}}\n" (if (or (null? seq) (not (pair? (rest seq)))) seq (end (rest seq))))
|
||||
|
||||
(define (last seq) :doc "Returns the (first) of the last (pair) of the given sequence.\n\n{{{example_start}}}\n(define a (list 1 2 3 4))\n(print (last a))\n{{{example_end}}}\n" (first (end seq)))
|
||||
|
||||
(define (extend seq elem) :doc "Extends a list with the given element, by putting it in\nthe (rest) of the last element of the sequence." (if (pair? seq) (begin (define e (end seq)) (mutate e (pair (first e) elem)) seq) elem))
|
||||
|
||||
(define (extend2 seq elem) :doc "Extends a list with the given element, by putting it in\nthe (rest) of the last element of the sequence." (print "addr of (end seq)" (addr-of (end seq))) (if (pair? seq) (let ((e (end seq))) (print "addr if e inner" (addr-of e)) (mutate e (pair (first e) elem)) seq)) elem)
|
||||
|
||||
(define (append seq elem) :doc "Appends an element to a sequence, by extendeing the list\nwith (pair elem nil)." (extend seq (pair elem ())))
|
||||
|
||||
(define (length seq) :doc "Returns the length of the given sequence." (if (null? seq) 0 (+ 1 (length (rest seq)))))
|
||||
|
||||
(define (member? elem seq) (when (pair? seq) (if (= elem (first seq)) t (member? elem (rest seq)))))
|
||||
|
||||
(define (sublist-starting-at-index seq index) (cond ((< index 0) (error :index-out-of-range "sublist-starting-at-index: index must be positive")) ((null? seq) ()) ((= 0 index) seq) (else (sublist-starting-at (rest seq) (- index 1)))))
|
||||
|
||||
(define (list-without-index seq index) (cond ((or (< index 0) (null? seq)) (error :index-out-of-range "list-remove-index!: index out of range")) ((= 0 index) (rest seq)) (else (pair (first seq) (list-without-index (rest seq) (- index 1))))))
|
||||
|
||||
(define (increment val) :doc "Adds one to the argument." (+ val 1))
|
||||
|
||||
(define (decrement val) :doc "Subtracts one from the argument." (- val 1))
|
||||
|
||||
(define (range (:from 0) :to) :doc "Returns a sequence of numbers starting with the number defined\nby the key =from= and ends with the number defined in =to=." (when (< from to) (pair from (range :from (+ 1 from) :to to))))
|
||||
|
||||
(define (range-while (:from 0) :to) :doc "Returns a sequence of numbers starting with the number defined\nby the key 'from' and ends with the number defined in 'to'." (define result (list (copy from))) (define head result) (set! from (increment from)) (while (< from to) (begin (mutate head (pair (first head) (pair (copy from) nil))) (define head (rest head)) (set! from (increment from)))) result)
|
||||
|
||||
(define (map fun seq) :doc "Takes a function and a sequence as arguments and returns a new\nsequence which contains the results of using the first sequences\nelemens as argument to that function." (if (null? seq) seq (pair (fun (first seq)) (map fun (rest seq)))))
|
||||
|
||||
(define (reduce fun seq) :doc "Takes a function and a sequence as arguments and applies the\nfunction to the argument sequence. This only works correctly if the\ngiven function accepts a variable amount of parameters. If your\nfunciton is limited to two arguments, use [[=reduce-binary=]]\ninstead." (apply fun seq))
|
||||
|
||||
(define (reduce-binary fun seq) :doc "Takes a function and a sequence as arguments and applies the\nfunction to the argument sequence. reduce-binary applies the arguments\n*pair-wise* which means it works with binary functions as compared to\n[[=reduce=]]." (if (null? (rest seq)) (first seq) (fun (first seq) (reduce-binary fun (rest seq)))))
|
||||
|
||||
(define (filter fun seq) :doc "Takes a function and a sequence as arguments and applies the\nfunction to every value in the sequence. If the result of that\nfunciton application returns a truthy value, the original value is\nadded to a list, which in the end is returned." (when seq (if (fun (first seq)) (pair (first seq) (filter fun (rest seq))) (filter fun (rest seq)))))
|
||||
|
||||
(define (zip l1 l2) (unless (and (null? l1) (null? l2)) (pair (list (first l1) (first l2)) (zip (rest l1) (rest l2)))))
|
||||
|
||||
(define (unzip lists) (when lists (define (iter lists l1 l2) (define elem (first lists)) (if elem (iter (rest lists) (pair (first elem) l1) (pair (first (rest elem)) l2)) (list l1 l2))) (iter lists () ())))
|
||||
|
||||
(define (enumerate seq) (define (enumerate-inner seq next-num) (when seq (pair (list (first seq) next-num) (enumerate-inner (rest seq) (+ 1 next-num))))) (enumerate-inner seq 0))
|
||||
|
||||
(define hm/set! hash-map-set!)
|
||||
|
||||
(define hm/get hash-map-get)
|
||||
|
||||
(define (hm/get-or-nil hm key) (mytry (hm/get hm key) ()))
|
||||
|
||||
(define-syntax (pe expr) `(print ',expr "evaluates to" ,expr))
|
||||
|
||||
(define the-empty-stream ())
|
||||
|
||||
(define (stream-null? s) (if s t ()))
|
||||
|
||||
(define-syntax (delay expr) `(,lambda () ,expr))
|
||||
|
||||
(define (force promise) (promise))
|
||||
|
||||
(define-syntax (when condition . body) :doc "Special form for when multiple actions should be done if a\ncondition is true.\n\n{{{example_start}}}\n(when (not ())\n (print "Hello ")\n (print "from ")\n (print "when!"))\n\n(when ()\n (print "Goodbye ")\n (print "World!"))\n{{{example_end}}}\n" (if (= (rest body) ()) `(if ,condition ,@body nil) `(if ,condition (begin ,@body) nil)))
|
||||
|
||||
(define-syntax (unless condition . body) :doc "Special form for when multiple actions should be done if a\ncondition is false." (if (= (rest body) ()) `(if ,condition nil ,@body) `(if ,condition nil (begin ,@body))))
|
||||
|
||||
(define-syntax (n-times times action) :doc "Executes action times times." (define (repeat times elem) (unless (> 1 times) (pair elem (repeat (- times 1) elem)))) `(begin ,@(repeat times action)))
|
||||
|
||||
(define-syntax (let bindings . body) (define (unzip lists) (when lists (define (iter lists l1 l2) (define elem (first lists)) (if elem (iter (rest lists) (pair (first elem) l1) (pair (first (rest elem)) l2)) (list l1 l2)))) (iter lists () ())) (define unzipped (unzip bindings)) `((,lambda ,(first unzipped) ,@body) ,@(first (rest unzipped))))
|
||||
|
||||
(define-syntax (cond . clauses) (define (rec clauses) (if (= nil clauses) nil (if (= (first (first clauses)) 'else) (begin (if (not (= (rest clauses) ())) (error :syntax-error "There are additional clauses after the else clause!") (pair 'begin (rest (first clauses))))) `(if ,(first (first clauses)) (begin ,@(rest (first clauses))) ,(rec (rest clauses)))))) (rec clauses))
|
||||
|
||||
(define-syntax (case var . clauses) (define (rec clauses) (if (= nil clauses) nil (if (= (first (first clauses)) 'else) (begin (if (not (= (rest clauses) ())) (error :syntax-error "There are additional clauses after the else clause!") (pair 'begin (rest (first clauses))))) `(if (member? ,var ',(first (first clauses))) (begin ,@(rest (first clauses))) ,(rec (rest clauses)))))) (rec clauses))
|
||||
|
||||
(define-syntax (construct-list . body) :doc "\n{{{example_start}}}\n(construct-list\n i <- '(1 2 3 4 5)\n yield (* i i))\n{{{example_end}}}\n\n(construct-list\n i <- '(1 2 3 4)\n j <- '(A B)\n yield (pair i j))\n\n(construct-list\n i <- '(1 2 3 4 5 6 7 8)\n if (= 0 (% i 2))\n yield i)\n" (define (append-map f ll) (unless (= ll ()) (define val (f (first ll))) (if (= (first val) ()) (append-map f (rest ll)) (extend val (append-map f (rest ll)))))) (define (rec body) (cond ((= () body) ()) ((= () (rest body)) (first body)) ((= (first (rest body)) '<-) `(,append-map (lambda (,(first body)) (list ,(rec (rest (rest (rest body)))))) ,(first (rest (rest body))))) ((= (first body) 'if) `(when ,(first (rest body)) ,(rec (rest (rest body))))) ((= (first (rest body)) 'yield) (first (rest body))) (else (error :syntax-error "Not a do-able expression")))) (rec body))
|
||||
|
||||
(define-syntax (define-typed args . body) (define (get-arg-names args) (when args (pair (first args) (get-arg-names (rest (rest args)))))) (let ((name (first args)) (lambda-list (rest args)) (arg-names (get-arg-names (rest args)))) `(define (,name ,@arg-names) (assert-types= ,@lambda-list) ,@body)))
|
||||
|
||||
(define-syntax (define-module module-name (:imports ()) :exports . body) (let ((module-prefix (concat-strings (symbol->string module-name) "::"))) (eval `(begin ,@(map (lambda (x) `(,import ,x)) imports) ,@body)) (pair 'begin (map (lambda (orig-export-name) (let ((export-name (string->symbol (concat-strings module-prefix (symbol->string orig-export-name))))) `(define ,export-name ,(mytry (eval orig-export-name) (error :module-error "The module does not contain a key it tries to export"))))) exports))))
|
||||
|
||||
(define-syntax (generic-extend args . body) (let ((fun-name (first args)) (params (rest args)) (types ()) (names ())) (define (process-params params) (when params (let ((_name (first params)) (_type (first (rest params)))) (assert (symbol? _name)) (assert (keyword? _type)) (set! types (append types _type)) (set! names (append names _name)) (process-params (rest (rest params)))))) (process-params params) (let ((generic-map-name (string->symbol (concat-strings "generic-" (symbol->string fun-name) "-map")))) (unless (bound? generic-map-name) (define generic-map-name (hash-map))) (hm/set! generic-map-name types (eval `(,lambda ,names ,@body))) (if (bound? fun-name) (let ((exisiting-fun (eval fun-name))) (unless (type=? exisiting-fun :generic-procedure) (unless (procedure? exisiting-fun) (error :macro-expand-error "can only generic-extend procedures.")) (define orig-proc exisiting-fun) (define fun-name (eval `(,lambda args (let ((fun (hm/get (map type args)))) (if (procedure? fun) (fun . args) (,orig-proc . args))))))))))))
|
||||
|
||||
(define (null? x) :doc "Checks if the argument is =nil=." (= x ()))
|
||||
|
||||
(define (type=? obj typ) :doc "Checks if the argument =obj= is of type =typ=" (= (type obj) typ))
|
||||
|
||||
(define (types=? . objs) (define (inner objs) (if objs (let ((actual-type (type (first objs))) (desired-type (first (rest objs)))) (if (= actual-type desired-type) (inner (rest (rest objs))) ())) t)) (inner objs))
|
||||
|
||||
(define (assert-types= . objs) (define (inner objs) (when objs (let ((actual-type (type (first objs))) (desired-type (first (rest objs)))) (if (= actual-type desired-type) (inner (rest (rest objs))) (error :type-missmatch "type missmatch" actual-type desired-type))))) (inner objs))
|
||||
|
||||
(define (number? x) :doc "Checks if the argument is a number." (type=? x :number))
|
||||
|
||||
(define (symbol? x) :doc "Checks if the argument is a symbol." (type=? x :symbol))
|
||||
|
||||
(define (keyword? x) :doc "Checks if the argument is a keyword." (type=? x :keyword))
|
||||
|
||||
(define (pair? x) :doc "Checks if the argument is a pair." (type=? x :pair))
|
||||
|
||||
(define (string? x) :doc "Checks if the argument is a string." (type=? x :string))
|
||||
|
||||
(define (lambda? x) :doc "Checks if the argument is a function." (type=? x :lambda))
|
||||
|
||||
(define (macro? x) :doc "Checks if the argument is a macro." (type=? x :macro))
|
||||
|
||||
(define (special-lambda? x) :doc "Checks if the argument is a special-lambda." (type=? x :dynamic-macro))
|
||||
|
||||
(define (built-in-function? x) :doc "Checks if the argument is a built-in function." (type=? x :cfunction))
|
||||
|
||||
(define (continuation? x) :doc "Checks if the argument is a continuation." (type=? x :continuation))
|
||||
|
||||
(define (procedure? x) (or (lambda? x) (special-lambda? x) (macro? x) (built-in-function? x) (continuation? x)))
|
||||
|
||||
(define (end seq) :doc "Returns the last pair in the sqeuence.\n\n{{{example_start}}}\n(define a (list 1 2 3 4))\n(print (end a))\n{{{example_end}}}\n" (if (or (null? seq) (not (pair? (rest seq)))) seq (end (rest seq))))
|
||||
|
||||
(define (last seq) :doc "Returns the (first) of the last (pair) of the given sequence.\n\n{{{example_start}}}\n(define a (list 1 2 3 4))\n(print (last a))\n{{{example_end}}}\n" (first (end seq)))
|
||||
|
||||
(define (extend seq elem) :doc "Extends a list with the given element, by putting it in\nthe (rest) of the last element of the sequence." (if (pair? seq) (begin (define e (end seq)) (mutate e (pair (first e) elem)) seq) elem))
|
||||
|
||||
(define (extend2 seq elem) :doc "Extends a list with the given element, by putting it in\nthe (rest) of the last element of the sequence." (print "addr of (end seq)" (addr-of (end seq))) (if (pair? seq) (let ((e (end seq))) (print "addr if e inner" (addr-of e)) (mutate e (pair (first e) elem)) seq)) elem)
|
||||
|
||||
(define (append seq elem) :doc "Appends an element to a sequence, by extendeing the list\nwith (pair elem nil)." (extend seq (pair elem ())))
|
||||
|
||||
(define (length seq) :doc "Returns the length of the given sequence." (if (null? seq) 0 (+ 1 (length (rest seq)))))
|
||||
|
||||
(define (member? elem seq) (when (pair? seq) (if (= elem (first seq)) t (member? elem (rest seq)))))
|
||||
|
||||
(define (sublist-starting-at-index seq index) (cond ((< index 0) (error :index-out-of-range "sublist-starting-at-index: index must be positive")) ((null? seq) ()) ((= 0 index) seq) (else (sublist-starting-at (rest seq) (- index 1)))))
|
||||
|
||||
(define (list-without-index seq index) (cond ((or (< index 0) (null? seq)) (error :index-out-of-range "list-remove-index!: index out of range")) ((= 0 index) (rest seq)) (else (pair (first seq) (list-without-index (rest seq) (- index 1))))))
|
||||
|
||||
(define (increment val) :doc "Adds one to the argument." (+ val 1))
|
||||
|
||||
(define (decrement val) :doc "Subtracts one from the argument." (- val 1))
|
||||
|
||||
(define (range (:from 0) :to) :doc "Returns a sequence of numbers starting with the number defined\nby the key =from= and ends with the number defined in =to=." (when (< from to) (pair from (range :from (+ 1 from) :to to))))
|
||||
|
||||
(define (range-while (:from 0) :to) :doc "Returns a sequence of numbers starting with the number defined\nby the key 'from' and ends with the number defined in 'to'." (define result (list (copy from))) (define head result) (set! from (increment from)) (while (< from to) (begin (mutate head (pair (first head) (pair (copy from) nil))) (define head (rest head)) (set! from (increment from)))) result)
|
||||
|
||||
(define (map fun seq) :doc "Takes a function and a sequence as arguments and returns a new\nsequence which contains the results of using the first sequences\nelemens as argument to that function." (if (null? seq) seq (pair (fun (first seq)) (map fun (rest seq)))))
|
||||
|
||||
(define (reduce fun seq) :doc "Takes a function and a sequence as arguments and applies the\nfunction to the argument sequence. This only works correctly if the\ngiven function accepts a variable amount of parameters. If your\nfunciton is limited to two arguments, use [[=reduce-binary=]]\ninstead." (apply fun seq))
|
||||
|
||||
(define (reduce-binary fun seq) :doc "Takes a function and a sequence as arguments and applies the\nfunction to the argument sequence. reduce-binary applies the arguments\n*pair-wise* which means it works with binary functions as compared to\n[[=reduce=]]." (if (null? (rest seq)) (first seq) (fun (first seq) (reduce-binary fun (rest seq)))))
|
||||
|
||||
(define (filter fun seq) :doc "Takes a function and a sequence as arguments and applies the\nfunction to every value in the sequence. If the result of that\nfunciton application returns a truthy value, the original value is\nadded to a list, which in the end is returned." (when seq (if (fun (first seq)) (pair (first seq) (filter fun (rest seq))) (filter fun (rest seq)))))
|
||||
|
||||
(define (zip l1 l2) (unless (and (null? l1) (null? l2)) (pair (list (first l1) (first l2)) (zip (rest l1) (rest l2)))))
|
||||
|
||||
(define (unzip lists) (when lists (define (iter lists l1 l2) (define elem (first lists)) (if elem (iter (rest lists) (pair (first elem) l1) (pair (first (rest elem)) l2)) (list l1 l2))) (iter lists () ())))
|
||||
|
||||
(define (enumerate seq) (define (enumerate-inner seq next-num) (when seq (pair (list (first seq) next-num) (enumerate-inner (rest seq) (+ 1 next-num))))) (enumerate-inner seq 0))
|
||||
|
||||
|
||||
+31
-31
@@ -1,31 +1,31 @@
|
||||
(define-module set
|
||||
:imports ("cxr.slime")
|
||||
:exports (make find contains? insert!)
|
||||
|
||||
(define key-not-found-index -1)
|
||||
|
||||
(define (make . vals)
|
||||
(set-type!
|
||||
(if vals
|
||||
(list vals)
|
||||
'(()))
|
||||
:set))
|
||||
|
||||
(define (find set val)
|
||||
(let ((values (car set)))
|
||||
(define (inner values current-index)
|
||||
(cond ((null? values) key-not-found-index)
|
||||
((= (car values) val) current-index)
|
||||
(else (inner (cdr values) (+ 1 current-index)))))
|
||||
(inner values 0)))
|
||||
|
||||
(define (contains? set val)
|
||||
(unless (= (find set val) key-not-found-index)
|
||||
t))
|
||||
|
||||
(define (insert! set value)
|
||||
(unless (contains? set value)
|
||||
(set! set (pair (pair value (first set)) ()))
|
||||
(set-type! set :set))
|
||||
set)
|
||||
)
|
||||
(define-module set
|
||||
:imports ("cxr.slime")
|
||||
:exports (make find contains? insert!)
|
||||
|
||||
(define key-not-found-index -1)
|
||||
|
||||
(define (make . vals)
|
||||
(set-type!
|
||||
(if vals
|
||||
(list vals)
|
||||
'(()))
|
||||
:set))
|
||||
|
||||
(define (find set val)
|
||||
(let ((values (car set)))
|
||||
(define (inner values current-index)
|
||||
(cond ((null? values) key-not-found-index)
|
||||
((= (car values) val) current-index)
|
||||
(else (inner (cdr values) (+ 1 current-index)))))
|
||||
(inner values 0)))
|
||||
|
||||
(define (contains? set val)
|
||||
(unless (= (find set val) key-not-found-index)
|
||||
t))
|
||||
|
||||
(define (insert! set value)
|
||||
(unless (contains? set value)
|
||||
(set! set (pair (pair value (first set)) ()))
|
||||
(set-type! set :set))
|
||||
set)
|
||||
)
|
||||
|
||||
+101
-101
@@ -1,101 +1,101 @@
|
||||
(import "alist.slime")
|
||||
|
||||
(define a (ds::alist::make))
|
||||
;; a == (())
|
||||
|
||||
(assert (= (first a) ()))
|
||||
|
||||
(ds::alist::set! a 'key1 'value1)
|
||||
;; a == (key1: value1)
|
||||
|
||||
(assert (= (ds::alist::get a 'key1) 'value1))
|
||||
(assert (ds::alist::key-exists? a 'key1))
|
||||
(assert (not (ds::alist::key-exists? a 'key2)))
|
||||
|
||||
(ds::alist::set! a 'key2 'value2)
|
||||
;; a == (key2: value2,
|
||||
;; key1: value1)
|
||||
|
||||
(assert (= (ds::alist::get a 'key2) 'value2))
|
||||
(assert (ds::alist::key-exists? a 'key2))
|
||||
(assert (= (ds::alist::find a 'key2) 0))
|
||||
(assert (= (ds::alist::find a 'key1) 1))
|
||||
(assert (= (length (first a)) 2))
|
||||
|
||||
|
||||
(ds::alist::set! a 'key1 'value3)
|
||||
;; a == (key1: value3,
|
||||
;; key2: value2,
|
||||
;; key1: value1)
|
||||
|
||||
(assert (= (length (first a)) 3))
|
||||
(assert (= (ds::alist::get a 'key1) 'value3))
|
||||
|
||||
(ds::alist::set-overwrite! a 'key1 'value4)
|
||||
;; a == (key1: value4,
|
||||
;; key2: value2,
|
||||
;; key1: value1)
|
||||
|
||||
(assert (= (length (first a)) 3))
|
||||
(assert (= (ds::alist::get a 'key1) 'value4))
|
||||
|
||||
(ds::alist::remove! a 'key1)
|
||||
;; a == (key2: value2,
|
||||
;; key1: value1)
|
||||
|
||||
(assert (= (length (first a)) 2))
|
||||
(assert (= (ds::alist::get a 'key1) 'value1))
|
||||
(assert (= (ds::alist::get a 'key2) 'value2))
|
||||
|
||||
|
||||
;; -------------
|
||||
;;
|
||||
;; PLISTS
|
||||
;;
|
||||
;; -------------
|
||||
|
||||
(define p (ds::plist::make))
|
||||
;; p == (())
|
||||
|
||||
(assert (= (first p) ()))
|
||||
|
||||
(ds::plist::set! p :key1 'value1)
|
||||
;; p == ((:key1 value1))
|
||||
|
||||
(assert (= (ds::plist::get p :key1) 'value1))
|
||||
(assert (ds::plist::prop-exists? p :key1))
|
||||
(assert (not (ds::plist::prop-exists? p :key2)))
|
||||
|
||||
(ds::plist::set! p :key2 'value2)
|
||||
;; p == ((:key2 value2,
|
||||
;; :key1 value1))
|
||||
|
||||
(assert (= (ds::plist::get p :key2) 'value2))
|
||||
(assert (ds::plist::prop-exists? p :key2))
|
||||
(assert (= (ds::plist::find p :key2) 0))
|
||||
(assert (= (ds::plist::find p :key1) 1))
|
||||
(assert (= (length (first p)) 4))
|
||||
|
||||
(ds::plist::set! p :key1 'value3)
|
||||
;; p == ((:key1 value3,
|
||||
;; :key2 value2,
|
||||
;; :key1 value1))
|
||||
|
||||
(assert (= (length (first p)) 6))
|
||||
(assert (= (ds::plist::get p :key1) 'value3))
|
||||
|
||||
(ds::plist::set-overwrite! p :key1 'value4)
|
||||
;; p == ((:key1 value4,
|
||||
;; :key2 value2,
|
||||
;; :key1 value1))
|
||||
|
||||
;; (assert (= (length (first p)) 6))
|
||||
;; (assert (= (ds::plist::get p :key1) 'value4))
|
||||
|
||||
;; (ds::plist::remove! p :key1)
|
||||
;; ;; p == ((:key2 value2,
|
||||
;; ;; :key1 value1))
|
||||
|
||||
;; (assert (= (length (first p)) 4))
|
||||
;; (assert (= (ds::plist::get p :key1) 'value1))
|
||||
;; (assert (= (ds::plist::get p :key2) 'value2))
|
||||
(import "alist.slime")
|
||||
|
||||
(define a (ds::alist::make))
|
||||
;; a == (())
|
||||
|
||||
(assert (= (first a) ()))
|
||||
|
||||
(ds::alist::set! a 'key1 'value1)
|
||||
;; a == (key1: value1)
|
||||
|
||||
(assert (= (ds::alist::get a 'key1) 'value1))
|
||||
(assert (ds::alist::key-exists? a 'key1))
|
||||
(assert (not (ds::alist::key-exists? a 'key2)))
|
||||
|
||||
(ds::alist::set! a 'key2 'value2)
|
||||
;; a == (key2: value2,
|
||||
;; key1: value1)
|
||||
|
||||
(assert (= (ds::alist::get a 'key2) 'value2))
|
||||
(assert (ds::alist::key-exists? a 'key2))
|
||||
(assert (= (ds::alist::find a 'key2) 0))
|
||||
(assert (= (ds::alist::find a 'key1) 1))
|
||||
(assert (= (length (first a)) 2))
|
||||
|
||||
|
||||
(ds::alist::set! a 'key1 'value3)
|
||||
;; a == (key1: value3,
|
||||
;; key2: value2,
|
||||
;; key1: value1)
|
||||
|
||||
(assert (= (length (first a)) 3))
|
||||
(assert (= (ds::alist::get a 'key1) 'value3))
|
||||
|
||||
(ds::alist::set-overwrite! a 'key1 'value4)
|
||||
;; a == (key1: value4,
|
||||
;; key2: value2,
|
||||
;; key1: value1)
|
||||
|
||||
(assert (= (length (first a)) 3))
|
||||
(assert (= (ds::alist::get a 'key1) 'value4))
|
||||
|
||||
(ds::alist::remove! a 'key1)
|
||||
;; a == (key2: value2,
|
||||
;; key1: value1)
|
||||
|
||||
(assert (= (length (first a)) 2))
|
||||
(assert (= (ds::alist::get a 'key1) 'value1))
|
||||
(assert (= (ds::alist::get a 'key2) 'value2))
|
||||
|
||||
|
||||
;; -------------
|
||||
;;
|
||||
;; PLISTS
|
||||
;;
|
||||
;; -------------
|
||||
|
||||
(define p (ds::plist::make))
|
||||
;; p == (())
|
||||
|
||||
(assert (= (first p) ()))
|
||||
|
||||
(ds::plist::set! p :key1 'value1)
|
||||
;; p == ((:key1 value1))
|
||||
|
||||
(assert (= (ds::plist::get p :key1) 'value1))
|
||||
(assert (ds::plist::prop-exists? p :key1))
|
||||
(assert (not (ds::plist::prop-exists? p :key2)))
|
||||
|
||||
(ds::plist::set! p :key2 'value2)
|
||||
;; p == ((:key2 value2,
|
||||
;; :key1 value1))
|
||||
|
||||
(assert (= (ds::plist::get p :key2) 'value2))
|
||||
(assert (ds::plist::prop-exists? p :key2))
|
||||
(assert (= (ds::plist::find p :key2) 0))
|
||||
(assert (= (ds::plist::find p :key1) 1))
|
||||
(assert (= (length (first p)) 4))
|
||||
|
||||
(ds::plist::set! p :key1 'value3)
|
||||
;; p == ((:key1 value3,
|
||||
;; :key2 value2,
|
||||
;; :key1 value1))
|
||||
|
||||
(assert (= (length (first p)) 6))
|
||||
(assert (= (ds::plist::get p :key1) 'value3))
|
||||
|
||||
(ds::plist::set-overwrite! p :key1 'value4)
|
||||
;; p == ((:key1 value4,
|
||||
;; :key2 value2,
|
||||
;; :key1 value1))
|
||||
|
||||
;; (assert (= (length (first p)) 6))
|
||||
;; (assert (= (ds::plist::get p :key1) 'value4))
|
||||
|
||||
;; (ds::plist::remove! p :key1)
|
||||
;; ;; p == ((:key2 value2,
|
||||
;; ;; :key1 value1))
|
||||
|
||||
;; (assert (= (length (first p)) 4))
|
||||
;; (assert (= (ds::plist::get p :key1) 'value1))
|
||||
;; (assert (= (ds::plist::get p :key2) 'value2))
|
||||
|
||||
@@ -1,14 +1,14 @@
|
||||
(import "oo.slime")
|
||||
|
||||
(define-class (vector3 x y z) (define (set-x new-x) (mutate x new-x)) (define (set-y new-y) (mutate y new-y)) (define (set-z new-z) (mutate z new-z)) (define (length) (** (+ (* x x) (* y y) (* z z)) 0.500000)) (define (scale fac) (mutate x (* fac x)) (mutate y (* fac y)) (mutate z (* fac z)) fac) (define (add other) (make-vector3 (+ (-> other x) x) (+ (-> other y) y) (+ (-> other z) z))) (define (subtract other) (make-vector3 (- (-> other x) x) (- (-> other y) y) (- (-> other z) z))) (define (equal? other) (and (= (-> other x) x) (= (-> other y) y) (= (-> other z) z))) (define (scalar-product other) (+ (* (-> other x) x) (* (-> other y) y) (* (-> other z) z))) (define (cross-product other) (make-vector3 (- (* (-> other z) y) (* (-> other y) z)) (- (* (-> other x) z) (* (-> other z) x)) (- (* (-> other y) x) (* (-> other x) y)))) (define (print) (printf :sep " " "[vector3] (" x y z ")")))
|
||||
|
||||
(define v1 (make-vector3 1 2 3))
|
||||
|
||||
(define v2 (make-vector3 3 2 1))
|
||||
|
||||
(assert (= (type v1) (type v2) :vector3))
|
||||
|
||||
(assert (= (v1 'scalar-product v2) 10))
|
||||
|
||||
(assert (-> (-> v1 cross-product v2) equal? (make-vector3 -4 8 -4)))
|
||||
|
||||
(import "oo.slime")
|
||||
|
||||
(define-class (vector3 x y z) (define (set-x new-x) (mutate x new-x)) (define (set-y new-y) (mutate y new-y)) (define (set-z new-z) (mutate z new-z)) (define (length) (** (+ (* x x) (* y y) (* z z)) 0.500000)) (define (scale fac) (mutate x (* fac x)) (mutate y (* fac y)) (mutate z (* fac z)) fac) (define (add other) (make-vector3 (+ (-> other x) x) (+ (-> other y) y) (+ (-> other z) z))) (define (subtract other) (make-vector3 (- (-> other x) x) (- (-> other y) y) (- (-> other z) z))) (define (equal? other) (and (= (-> other x) x) (= (-> other y) y) (= (-> other z) z))) (define (scalar-product other) (+ (* (-> other x) x) (* (-> other y) y) (* (-> other z) z))) (define (cross-product other) (make-vector3 (- (* (-> other z) y) (* (-> other y) z)) (- (* (-> other x) z) (* (-> other z) x)) (- (* (-> other y) x) (* (-> other x) y)))) (define (print) (printf :sep " " "[vector3] (" x y z ")")))
|
||||
|
||||
(define v1 (make-vector3 1 2 3))
|
||||
|
||||
(define v2 (make-vector3 3 2 1))
|
||||
|
||||
(assert (= (type v1) (type v2) :vector3))
|
||||
|
||||
(assert (= (v1 'scalar-product v2) 10))
|
||||
|
||||
(assert (-> (-> v1 cross-product v2) equal? (make-vector3 -4 8 -4)))
|
||||
|
||||
|
||||
@@ -1,15 +1,15 @@
|
||||
((lambda ((:k1 (+ 1 2 3)))
|
||||
(assert (= k1 6))))
|
||||
|
||||
((lambda ((:k1 ()))
|
||||
(when k1
|
||||
(assert ()))
|
||||
(assert (= k1 ()))))
|
||||
|
||||
(define (test)
|
||||
((lambda ()
|
||||
(define (a)
|
||||
:ok)
|
||||
(define (b (:k (begin (break) (a))))
|
||||
k)
|
||||
(b))))
|
||||
((lambda ((:k1 (+ 1 2 3)))
|
||||
(assert (= k1 6))))
|
||||
|
||||
((lambda ((:k1 ()))
|
||||
(when k1
|
||||
(assert ()))
|
||||
(assert (= k1 ()))))
|
||||
|
||||
(define (test)
|
||||
((lambda ()
|
||||
(define (a)
|
||||
:ok)
|
||||
(define (b (:k (begin (break) (a))))
|
||||
k)
|
||||
(b))))
|
||||
|
||||
+25
-25
@@ -1,25 +1,25 @@
|
||||
|
||||
(define hm1 (hash-map))
|
||||
|
||||
(hm/set! hm1 1 "a")
|
||||
(hm/set! hm1 "a" (lambda (x) (+ x 1)))
|
||||
|
||||
(assert (= ((hm/get hm1 (hm/get hm1 1)) 2) 3))
|
||||
|
||||
(define hm2 (hash-map))
|
||||
(hm/set! hm2 'yes :yes)
|
||||
(hm/set! hm2 :yes 'yes)
|
||||
|
||||
(assert (= (hm/get hm2 'yes) :yes))
|
||||
(assert (= (hm/get hm2 :yes) 'yes))
|
||||
(assert (= (hm/get hm2 (hm/get hm2 'yes)) 'yes))
|
||||
(assert (= (hm/get hm2 (hm/get hm2 :yes)) :yes))
|
||||
(assert (= (hm/get hm2 (hm/get hm2 (hm/get hm2 'yes))) :yes))
|
||||
(assert (= (hm/get hm2 (hm/get hm2 (hm/get hm2 :yes))) 'yes))
|
||||
|
||||
(define hm3 (hash-map))
|
||||
(hm/set! hm3 + 'plus)
|
||||
(hm/set! hm3 - 'minus)
|
||||
|
||||
(assert (= (hm/get hm3 +) 'plus))
|
||||
(assert (= (hm/get hm3 -) 'minus))
|
||||
|
||||
(define hm1 (hash-map))
|
||||
|
||||
(hm/set! hm1 1 "a")
|
||||
(hm/set! hm1 "a" (lambda (x) (+ x 1)))
|
||||
|
||||
(assert (= ((hm/get hm1 (hm/get hm1 1)) 2) 3))
|
||||
|
||||
(define hm2 (hash-map))
|
||||
(hm/set! hm2 'yes :yes)
|
||||
(hm/set! hm2 :yes 'yes)
|
||||
|
||||
(assert (= (hm/get hm2 'yes) :yes))
|
||||
(assert (= (hm/get hm2 :yes) 'yes))
|
||||
(assert (= (hm/get hm2 (hm/get hm2 'yes)) 'yes))
|
||||
(assert (= (hm/get hm2 (hm/get hm2 :yes)) :yes))
|
||||
(assert (= (hm/get hm2 (hm/get hm2 (hm/get hm2 'yes))) :yes))
|
||||
(assert (= (hm/get hm2 (hm/get hm2 (hm/get hm2 :yes))) 'yes))
|
||||
|
||||
(define hm3 (hash-map))
|
||||
(hm/set! hm3 + 'plus)
|
||||
(hm/set! hm3 - 'minus)
|
||||
|
||||
(assert (= (hm/get hm3 +) 'plus))
|
||||
(assert (= (hm/get hm3 -) 'minus))
|
||||
|
||||
@@ -1,3 +1,3 @@
|
||||
(define a 1111)
|
||||
|
||||
(define (get-a-1) a)
|
||||
(define a 1111)
|
||||
|
||||
(define (get-a-1) a)
|
||||
|
||||
@@ -1,7 +1,7 @@
|
||||
(import "tests/import1.slime")
|
||||
|
||||
|
||||
(define (set-a-2 s)
|
||||
(set! a s))
|
||||
|
||||
(define (get-a-2) a)
|
||||
(import "tests/import1.slime")
|
||||
|
||||
|
||||
(define (set-a-2 s)
|
||||
(set! a s))
|
||||
|
||||
(define (get-a-2) a)
|
||||
|
||||
@@ -1,59 +1,59 @@
|
||||
;; regular arguments
|
||||
|
||||
(define (make-counter)
|
||||
(let ((var 0))
|
||||
(lambda ()
|
||||
(set! var (+ 1 var)))))
|
||||
|
||||
(define counter1 (make-counter))
|
||||
|
||||
(assert (= (counter1) 1))
|
||||
|
||||
(define counter2 (make-counter))
|
||||
|
||||
(assert (= (counter2) 1))
|
||||
|
||||
(assert (= (counter2) 2))
|
||||
(assert (= (counter1) 2))
|
||||
(assert (= (counter1) 3))
|
||||
(assert (= (counter2) 3))
|
||||
(assert (= (counter2) 4))
|
||||
(assert (= (counter2) 5))
|
||||
(assert (= (counter1) 4))
|
||||
(assert (= (counter1) 5))
|
||||
|
||||
(define (g)
|
||||
(define x 0)
|
||||
(lambda ()
|
||||
(define temp x)
|
||||
(mutate x (+ x 1))
|
||||
temp))
|
||||
|
||||
;; key arguments
|
||||
|
||||
(define (make-key-counter)
|
||||
((lambda (:var)
|
||||
(lambda ()
|
||||
(mutate var (+ 1 var))
|
||||
var))
|
||||
:var 0))
|
||||
|
||||
|
||||
(define key-counter1 (make-key-counter))
|
||||
|
||||
(assert (= (key-counter1) 1))
|
||||
|
||||
(define key-counter2 (make-key-counter))
|
||||
|
||||
(assert (= (key-counter2) 1))
|
||||
|
||||
(assert (= (key-counter2) 2))
|
||||
(assert (= (key-counter1) 2))
|
||||
(assert (= (key-counter1) 3))
|
||||
(assert (= (key-counter2) 3))
|
||||
(assert (= (key-counter2) 4))
|
||||
(assert (= (key-counter2) 5))
|
||||
(assert (= (key-counter1) 4))
|
||||
(assert (= (key-counter1) 5))
|
||||
|
||||
;; rest arguments will no be copied so we don't need to test them here
|
||||
;; regular arguments
|
||||
|
||||
(define (make-counter)
|
||||
(let ((var 0))
|
||||
(lambda ()
|
||||
(set! var (+ 1 var)))))
|
||||
|
||||
(define counter1 (make-counter))
|
||||
|
||||
(assert (= (counter1) 1))
|
||||
|
||||
(define counter2 (make-counter))
|
||||
|
||||
(assert (= (counter2) 1))
|
||||
|
||||
(assert (= (counter2) 2))
|
||||
(assert (= (counter1) 2))
|
||||
(assert (= (counter1) 3))
|
||||
(assert (= (counter2) 3))
|
||||
(assert (= (counter2) 4))
|
||||
(assert (= (counter2) 5))
|
||||
(assert (= (counter1) 4))
|
||||
(assert (= (counter1) 5))
|
||||
|
||||
(define (g)
|
||||
(define x 0)
|
||||
(lambda ()
|
||||
(define temp x)
|
||||
(mutate x (+ x 1))
|
||||
temp))
|
||||
|
||||
;; key arguments
|
||||
|
||||
(define (make-key-counter)
|
||||
((lambda (:var)
|
||||
(lambda ()
|
||||
(mutate var (+ 1 var))
|
||||
var))
|
||||
:var 0))
|
||||
|
||||
|
||||
(define key-counter1 (make-key-counter))
|
||||
|
||||
(assert (= (key-counter1) 1))
|
||||
|
||||
(define key-counter2 (make-key-counter))
|
||||
|
||||
(assert (= (key-counter2) 1))
|
||||
|
||||
(assert (= (key-counter2) 2))
|
||||
(assert (= (key-counter1) 2))
|
||||
(assert (= (key-counter1) 3))
|
||||
(assert (= (key-counter2) 3))
|
||||
(assert (= (key-counter2) 4))
|
||||
(assert (= (key-counter2) 5))
|
||||
(assert (= (key-counter1) 4))
|
||||
(assert (= (key-counter1) 5))
|
||||
|
||||
;; rest arguments will no be copied so we don't need to test them here
|
||||
|
||||
@@ -1,54 +1,54 @@
|
||||
(define (make-counter) (let ((var 0)) (lambda () (set! var (+ 1 var)))))
|
||||
|
||||
(define counter1 (make-counter))
|
||||
|
||||
(assert (= (counter1) 1))
|
||||
|
||||
(define counter2 (make-counter))
|
||||
|
||||
(assert (= (counter2) 1))
|
||||
|
||||
(assert (= (counter2) 2))
|
||||
|
||||
(assert (= (counter1) 2))
|
||||
|
||||
(assert (= (counter1) 3))
|
||||
|
||||
(assert (= (counter2) 3))
|
||||
|
||||
(assert (= (counter2) 4))
|
||||
|
||||
(assert (= (counter2) 5))
|
||||
|
||||
(assert (= (counter1) 4))
|
||||
|
||||
(assert (= (counter1) 5))
|
||||
|
||||
(define (g) (define x 0) (lambda () (define temp x) (mutate x (+ x 1)) temp))
|
||||
|
||||
(define (make-key-counter) ((lambda (:var) (lambda () (mutate var (+ 1 var)) var)) :var 0))
|
||||
|
||||
(define key-counter1 (make-key-counter))
|
||||
|
||||
(assert (= (key-counter1) 1))
|
||||
|
||||
(define key-counter2 (make-key-counter))
|
||||
|
||||
(assert (= (key-counter2) 1))
|
||||
|
||||
(assert (= (key-counter2) 2))
|
||||
|
||||
(assert (= (key-counter1) 2))
|
||||
|
||||
(assert (= (key-counter1) 3))
|
||||
|
||||
(assert (= (key-counter2) 3))
|
||||
|
||||
(assert (= (key-counter2) 4))
|
||||
|
||||
(assert (= (key-counter2) 5))
|
||||
|
||||
(assert (= (key-counter1) 4))
|
||||
|
||||
(assert (= (key-counter1) 5))
|
||||
|
||||
(define (make-counter) (let ((var 0)) (lambda () (set! var (+ 1 var)))))
|
||||
|
||||
(define counter1 (make-counter))
|
||||
|
||||
(assert (= (counter1) 1))
|
||||
|
||||
(define counter2 (make-counter))
|
||||
|
||||
(assert (= (counter2) 1))
|
||||
|
||||
(assert (= (counter2) 2))
|
||||
|
||||
(assert (= (counter1) 2))
|
||||
|
||||
(assert (= (counter1) 3))
|
||||
|
||||
(assert (= (counter2) 3))
|
||||
|
||||
(assert (= (counter2) 4))
|
||||
|
||||
(assert (= (counter2) 5))
|
||||
|
||||
(assert (= (counter1) 4))
|
||||
|
||||
(assert (= (counter1) 5))
|
||||
|
||||
(define (g) (define x 0) (lambda () (define temp x) (mutate x (+ x 1)) temp))
|
||||
|
||||
(define (make-key-counter) ((lambda (:var) (lambda () (mutate var (+ 1 var)) var)) :var 0))
|
||||
|
||||
(define key-counter1 (make-key-counter))
|
||||
|
||||
(assert (= (key-counter1) 1))
|
||||
|
||||
(define key-counter2 (make-key-counter))
|
||||
|
||||
(assert (= (key-counter2) 1))
|
||||
|
||||
(assert (= (key-counter2) 2))
|
||||
|
||||
(assert (= (key-counter1) 2))
|
||||
|
||||
(assert (= (key-counter1) 3))
|
||||
|
||||
(assert (= (key-counter2) 3))
|
||||
|
||||
(assert (= (key-counter2) 4))
|
||||
|
||||
(assert (= (key-counter2) 5))
|
||||
|
||||
(assert (= (key-counter1) 4))
|
||||
|
||||
(assert (= (key-counter1) 5))
|
||||
|
||||
|
||||
+22
-13
@@ -1,13 +1,22 @@
|
||||
;; (define-module math
|
||||
;; :exports
|
||||
;; (pi tau pow sqrt)
|
||||
|
||||
;; (define pi 3.1415)
|
||||
;; (define tau (* 2 pi))
|
||||
;; (define (pow a b) (** a b))
|
||||
;; (define (sqrt a) (** a 0.5)))
|
||||
|
||||
;; (assert (= math::pi 3.1415))
|
||||
;; (assert (= math::tau (* 2 math::tau)))
|
||||
|
||||
(1 2 3)
|
||||
;; (define-module math
|
||||
;; :exports
|
||||
;; (pi tau pow sqrt)
|
||||
|
||||
;; (define pi 3.1415)
|
||||
;; (define tau (* 2 pi))
|
||||
;; (define (pow a b) (** a b))
|
||||
;; (define (sqrt a) (** a 0.5)))
|
||||
|
||||
;; (assert (= math::pi 3.1415))
|
||||
;; (assert (= math::tau (* 2 math::tau)))
|
||||
|
||||
|
||||
(tdefine-module 'math
|
||||
:exports
|
||||
'(pi tau pow sqrt)
|
||||
|
||||
'(define pi 3.1415)
|
||||
'(define tau (* 2 pi))
|
||||
'(define (pow a b) (** a b))
|
||||
'(define (sqrt a) (** a 0.5)))
|
||||
|
||||
|
||||
+348
-340
@@ -1,340 +1,348 @@
|
||||
;; (define (abs x)
|
||||
;; (cond ((< x 0) (- x))
|
||||
;; (else x)))
|
||||
|
||||
;; (assert (= (abs 1) 1))
|
||||
;; (assert (= (abs (- 2)) 2))
|
||||
|
||||
|
||||
(define (abs x)
|
||||
(if (< x 0)
|
||||
(- x)
|
||||
x))
|
||||
|
||||
;; (assert (= (abs 12) 12))
|
||||
;; (assert (= (abs (- 32)) 32))
|
||||
|
||||
|
||||
;; (define (>= x y)
|
||||
;; (or (> x y)
|
||||
;; (= x y)))
|
||||
|
||||
;; (assert (>= 2 2))
|
||||
;; (assert (>= 3 2))
|
||||
;; (assert (not (>= 1 2)))
|
||||
;; (assert (not (>= 12 44)))
|
||||
|
||||
|
||||
;; (define (>= x y)
|
||||
;; (not (< x y)))
|
||||
|
||||
;; (assert (>= 2 2))
|
||||
;; (assert (>= 3 2))
|
||||
;; (assert (not (>= 1 2)))
|
||||
;; (assert (not (>= 12 44)))
|
||||
|
||||
|
||||
;; (define (a-plus-abs-b a b)
|
||||
;; ((if (> b 0) + -) a b))
|
||||
|
||||
;; (assert (= (a-plus-abs-b 1 2) 3))
|
||||
;; (assert (= (a-plus-abs-b 1 -2) 3))
|
||||
|
||||
(define (square x) (* x x))
|
||||
(define (cube x) (* x x x))
|
||||
|
||||
;; (assert (= ((lambda (x y z)
|
||||
;; (+ x y (square z)))
|
||||
;; 1 2 3)
|
||||
;; 12))
|
||||
|
||||
;; ;;; --------------------
|
||||
;; ;;; newtons method
|
||||
;; ;;; --------------------
|
||||
|
||||
;; (define tolerance 0.001)
|
||||
|
||||
;; (define (square x)
|
||||
;; (* x x))
|
||||
|
||||
(define (average x y)
|
||||
(/ (+ x y) 2))
|
||||
|
||||
;; (define (improve guess x)
|
||||
;; (average guess (/ x guess)))
|
||||
|
||||
;; (define (good-enough? guess x)
|
||||
;; (< (abs (- (square guess) x)) tolerance))
|
||||
|
||||
;; (define (sqrt-iter guess x)
|
||||
;; (if (good-enough? guess x)
|
||||
;; guess
|
||||
;; (sqrt-iter (improve guess x) x)))
|
||||
|
||||
;; (define (sqrt x)
|
||||
;; (sqrt-iter 1.0 x))
|
||||
|
||||
;; (define (sqrt2 x)
|
||||
;; (define (good-enough? guess x)
|
||||
;; (< (abs (- (square guess) x)) 0.001))
|
||||
|
||||
;; (define (improve guess x)
|
||||
;; (average guess (/ x guess)))
|
||||
|
||||
;; (define (sqrt-iter guess x)
|
||||
;; (if (good-enough? guess x)
|
||||
;; guess
|
||||
;; (sqrt-iter (improve guess x) x)))
|
||||
|
||||
;; (sqrt-iter 1.0 x))
|
||||
|
||||
;; (define (sqrt3 x)
|
||||
;; (define (good-enough? guess)
|
||||
;; (< (abs (- (square guess) x)) 0.001))
|
||||
|
||||
;; (define (improve guess)
|
||||
;; (average guess (/ x guess)))
|
||||
|
||||
;; (define (sqrt-iter guess)
|
||||
;; (if (good-enough? guess)
|
||||
;; guess
|
||||
;; (sqrt-iter (improve guess))))
|
||||
|
||||
;; (sqrt-iter 1.0))
|
||||
|
||||
;; (assert (< (abs (- 3 (sqrt 9))) tolerance))
|
||||
;; (assert (< (abs (- 4 (sqrt 16))) tolerance))
|
||||
;; (assert (not (< (abs (- 4 (sqrt 15))) tolerance)))
|
||||
|
||||
;; (assert (< (abs (- 3 (sqrt2 9))) tolerance))
|
||||
;; (assert (< (abs (- 4 (sqrt2 16))) tolerance))
|
||||
;; (assert (not (< (abs (- 4 (sqrt2 15))) tolerance)))
|
||||
|
||||
;; (assert (< (abs (- 3 (sqrt3 9))) tolerance))
|
||||
;; (assert (< (abs (- 4 (sqrt3 16))) tolerance))
|
||||
;; (assert (not (< (abs (- 4 (sqrt3 15))) tolerance)))
|
||||
|
||||
|
||||
;; ;;; -----------------
|
||||
;; ;;; factorial
|
||||
;; ;;; -----------------
|
||||
|
||||
(define (factorial n)
|
||||
(if (= n 1)
|
||||
1
|
||||
(* n (factorial (- n 1)))))
|
||||
|
||||
(define (factorial2 n)
|
||||
(fact-iter 1 1 n))
|
||||
|
||||
(define (fact-iter product counter max-count)
|
||||
(if (> counter max-count)
|
||||
product
|
||||
(fact-iter (* counter product) (+ counter 1) max-count)))
|
||||
|
||||
(define (factorial3 n)
|
||||
(define (iter product counter)
|
||||
(if (> counter n)
|
||||
product
|
||||
(iter (* counter product) (+ counter 1))))
|
||||
|
||||
(iter 1 1))
|
||||
|
||||
(assert (= (factorial 6) 720))
|
||||
(assert (= (factorial2 6) 720))
|
||||
(assert (= (factorial3 6) 720))
|
||||
|
||||
;;; ----------------
|
||||
;;; ackermann
|
||||
;;; ----------------
|
||||
|
||||
(define (A m n)
|
||||
(cond ((= m 0) (+ n 1))
|
||||
((= n 0) (A (- m 1) 1))
|
||||
(else (A (- m 1) (A m (- n 1))))))
|
||||
|
||||
(assert (= (A 0 0) 1))
|
||||
(assert (= (A 1 2) 4))
|
||||
(assert (= (A 3 1) 13))
|
||||
|
||||
|
||||
;; ;;; ---------------
|
||||
;; ;;; Fibonacci
|
||||
;; ;;; ---------------
|
||||
|
||||
;; (define (fib n)
|
||||
;; (cond ((= n 0) 0)
|
||||
;; ((= n 1) 1)
|
||||
;; (else (+ (fib (- n 1)) (fib (- n 2))))))
|
||||
|
||||
;; (define (fib2 n)
|
||||
;; (fib-iter 1 0 n))
|
||||
|
||||
;; (define (fib-iter a b count)
|
||||
;; (if (= count 0)
|
||||
;; b
|
||||
;; (fib-iter (+ a b) a (- count 1))))
|
||||
|
||||
;; (assert (= (fib 2) 1))
|
||||
;; (assert (= (fib 3) 2))
|
||||
;; (assert (= (fib 4) 3))
|
||||
;; (assert (= (fib 5) 5))
|
||||
;; (assert (= (fib 6) 8))
|
||||
|
||||
;; (assert (= (fib2 2) 1))
|
||||
;; (assert (= (fib2 3) 2))
|
||||
;; (assert (= (fib2 4) 3))
|
||||
;; (assert (= (fib2 5) 5))
|
||||
;; (assert (= (fib2 6) 8))
|
||||
|
||||
;; ;;; ------------------
|
||||
;; ;;; count change
|
||||
;; ;;; ------------------
|
||||
|
||||
;; (define (count-change amount)
|
||||
;; (define (cc amount kinds-of-coins)
|
||||
;; (cond ((= amount 0) 1)
|
||||
;; ((or (< amount 0) (= kinds-of-coins 0)) 0)
|
||||
;; (else (+ (cc amount (- kinds-of-coins 1))
|
||||
;; (cc (- amount (first-denomination kinds-of-coins)) kinds-of-coins)))))
|
||||
|
||||
;; (define (first-denomination kinds-of-coins)
|
||||
;; (cond ((= kinds-of-coins 1) 1)
|
||||
;; ((= kinds-of-coins 2) 5)
|
||||
;; ((= kinds-of-coins 3) 10)
|
||||
;; ((= kinds-of-coins 4) 25)
|
||||
;; ((= kinds-of-coins 5) 50)))
|
||||
|
||||
;; (cc amount 5))
|
||||
|
||||
;; (assert (= (count-change 100) 292))
|
||||
|
||||
;; ;;; --------------------
|
||||
;; ;;; exponentiation
|
||||
;; ;;; --------------------
|
||||
|
||||
;; (define (expt b n)
|
||||
;; (if (= n 0)
|
||||
;; 1
|
||||
;; (* b (expt b (- n 1)))))
|
||||
|
||||
;; (define (expt2 b n)
|
||||
;; (define (expt-iter b counter product)
|
||||
;; (if (= counter 0)
|
||||
;; product
|
||||
;; (expt-iter b (- counter 1) (* b product))))
|
||||
|
||||
;; (expt-iter b n 1))
|
||||
|
||||
;; (define (fast-expt b n)
|
||||
;; (define (even? n)
|
||||
;; (= (% n 2) 0))
|
||||
|
||||
;; (cond ((= n 0) 1)
|
||||
;; ((even? n) (square (fast-expt b (/ n 2))))
|
||||
;; (else (* b (fast-expt b (- n 1))))))
|
||||
|
||||
;; (assert (= (expt 1 2) 1))
|
||||
;; (assert (= (expt 2 2) 4))
|
||||
;; (assert (= (expt 2 3) 8))
|
||||
|
||||
;; (assert (= (expt2 1 2) 1))
|
||||
;; (assert (= (expt2 2 2) 4))
|
||||
;; (assert (= (expt2 2 3) 8))
|
||||
|
||||
;; (assert (= (fast-expt 1 2) 1))
|
||||
;; (assert (= (fast-expt 2 2) 4))
|
||||
;; (assert (= (fast-expt 2 3) 8))
|
||||
|
||||
;; ;;; ----------
|
||||
;; ;;; gcd
|
||||
;; ;;; ----------
|
||||
|
||||
;; (define (gcd a b)
|
||||
;; (if (= b 0)
|
||||
;; a
|
||||
;; (gcd b (% a b))))
|
||||
|
||||
;; (assert (= (gcd 40 6) 2))
|
||||
;; (assert (= (gcd 13 4) 1))
|
||||
|
||||
|
||||
;; ;;; ----------
|
||||
;; ;;; primes
|
||||
;; ;;; ----------
|
||||
|
||||
;; (define (smallest-divisor n)
|
||||
;; (find-divisor n 2))
|
||||
|
||||
;; (define (find-divisor n test-divisor)
|
||||
;; (cond ((> (square test-divisor) n) n)
|
||||
;; ((divides? test-divisor n) test-divisor)
|
||||
;; (else (find-divisor n (+ test-divisor 1)))))
|
||||
|
||||
;; (define (divides? a b)
|
||||
;; (= (% b a) 0))
|
||||
|
||||
;; (define (prime? n)
|
||||
;; (= n (smallest-divisor n)))
|
||||
|
||||
;; (assert (prime? 13))
|
||||
;; (assert (prime? 11))
|
||||
;; (assert (not (prime? 12)))
|
||||
|
||||
|
||||
;;; ----------------------
|
||||
;;; simple integral
|
||||
;;; ----------------------
|
||||
|
||||
;; (define (sum term a next b)
|
||||
;; (if (> a b)
|
||||
;; 0
|
||||
;; (+ (term a) (sum term (next a) next b))))
|
||||
|
||||
;; (define (integral f a b dx)
|
||||
;; (define (add-dx x) (+ x dx))
|
||||
;; (* (sum f (+ a (/ dx 2.0)) add-dx b) dx))
|
||||
|
||||
;; (define (pi-sum a b)
|
||||
;; (define (pi-term x) (/ 1.0 (* x (+ x 2))))
|
||||
;; (define (pi-next x) (+ x 4))
|
||||
;; (sum pi-term a pi-next b))
|
||||
|
||||
;; (assert (< (abs (- (* 8 (pi-sum 1 100)) 3.121595)) 0.0001))
|
||||
;; (assert (< (abs (- (integral cube 0 1 0.02) 0.249950)) 0.0001))
|
||||
|
||||
|
||||
;; ------------------------------------------------------------
|
||||
;; F(x,y) = x(1 + xy)^2 + y(1 − y) + (1 + xy)(1 − y)
|
||||
;; ------------------------------------------------------------
|
||||
|
||||
;; (define (f x y)
|
||||
;; (let ((a (+ 1 (* x y)))
|
||||
;; (b (- 1 y)))
|
||||
;; (+ (* x (square a))
|
||||
;; (* y b)
|
||||
;; (* a b))))
|
||||
|
||||
;; (assert (= (f 0 0) 1))
|
||||
;; (assert (= (f 1 1) 4))
|
||||
|
||||
|
||||
;; ;;; ---------------
|
||||
;; ;;; find zero
|
||||
;; ;;; ---------------
|
||||
|
||||
;; (define (positive? x) (< 0 x))
|
||||
;; (define (negative? x) (< x 0))
|
||||
|
||||
;; (define (search f neg-point pos-point)
|
||||
;; (let ((midpoint (average neg-point pos-point)))
|
||||
;; (if (close-enough? neg-point pos-point)
|
||||
;; midpoint
|
||||
;; (let ((test-value (f midpoint)))
|
||||
;; (cond ((positive? test-value) (search f neg-point midpoint))
|
||||
;; ((negative? test-value) (search f midpoint pos-point))
|
||||
;; (else midpoint))))))
|
||||
|
||||
;; (define (close-enough? x y) (< (abs (- x y)) 0.001))
|
||||
|
||||
;; (assert (close-enough? (search (lambda (x) (- 1 (square x))) -3 3) -1))
|
||||
|
||||
;; (define (abs x)
|
||||
;; (cond ((< x 0) (- x))
|
||||
;; (else x)))
|
||||
|
||||
;; (assert (= (abs 1) 1))
|
||||
;; (assert (= (abs (- 2)) 2))
|
||||
|
||||
|
||||
;; (define (abs x)
|
||||
;; (if (< x 0)
|
||||
;; (- x)
|
||||
;; x))
|
||||
|
||||
;; (assert (= (abs 12) 12))
|
||||
;; (assert (= (abs (- 32)) 32))
|
||||
|
||||
|
||||
;; (define (>= x y)
|
||||
;; (or (> x y)
|
||||
;; (= x y)))
|
||||
|
||||
;; (assert (>= 2 2))
|
||||
;; (assert (>= 3 2))
|
||||
;; (assert (not (>= 1 2)))
|
||||
;; (assert (not (>= 12 44)))
|
||||
|
||||
|
||||
;; (define (>= x y)
|
||||
;; (not (< x y)))
|
||||
|
||||
;; (assert (>= 2 2))
|
||||
;; (assert (>= 3 2))
|
||||
;; (assert (not (>= 1 2)))
|
||||
;; (assert (not (>= 12 44)))
|
||||
|
||||
|
||||
;; (define (a-plus-abs-b a b)
|
||||
;; ((if (> b 0) + -) a b))
|
||||
|
||||
;; (assert (= (a-plus-abs-b 1 2) 3))
|
||||
;; (assert (= (a-plus-abs-b 1 -2) 3))
|
||||
|
||||
;; (define (square x) (* x x))
|
||||
;; (define (cube x) (* x x x))
|
||||
|
||||
;; (assert (= ((lambda (x y z)
|
||||
;; (+ x y (square z)))
|
||||
;; 1 2 3)
|
||||
;; 12))
|
||||
|
||||
;; ;;; --------------------
|
||||
;; ;;; newtons method
|
||||
;; ;;; --------------------
|
||||
|
||||
;; (define tolerance 0.001)
|
||||
|
||||
;; (define (square x)
|
||||
;; (* x x))
|
||||
|
||||
;; (define (average x y)
|
||||
;; (/ (+ x y) 2))
|
||||
|
||||
;; (define (improve guess x)
|
||||
;; (average guess (/ x guess)))
|
||||
|
||||
;; (define (good-enough? guess x)
|
||||
;; (< (abs (- (square guess) x)) tolerance))
|
||||
|
||||
;; (define (sqrt-iter guess x)
|
||||
;; (if (good-enough? guess x)
|
||||
;; guess
|
||||
;; (sqrt-iter (improve guess x) x)))
|
||||
|
||||
;; (define (sqrt x)
|
||||
;; (sqrt-iter 1.0 x))
|
||||
|
||||
;; (define (sqrt2 x)
|
||||
;; (define (good-enough? guess x)
|
||||
;; (< (abs (- (square guess) x)) 0.001))
|
||||
|
||||
;; (define (improve guess x)
|
||||
;; (average guess (/ x guess)))
|
||||
|
||||
;; (define (sqrt-iter guess x)
|
||||
;; (if (good-enough? guess x)
|
||||
;; guess
|
||||
;; (sqrt-iter (improve guess x) x)))
|
||||
|
||||
;; (sqrt-iter 1.0 x))
|
||||
|
||||
;; (define (sqrt3 x)
|
||||
;; (define (good-enough? guess)
|
||||
;; (< (abs (- (square guess) x)) 0.001))
|
||||
|
||||
;; (define (improve guess)
|
||||
;; (average guess (/ x guess)))
|
||||
|
||||
;; (define (sqrt-iter guess)
|
||||
;; (if (good-enough? guess)
|
||||
;; guess
|
||||
;; (sqrt-iter (improve guess))))
|
||||
|
||||
;; (sqrt-iter 1.0))
|
||||
|
||||
;; (assert (< (abs (- 3 (sqrt 9))) tolerance))
|
||||
;; (assert (< (abs (- 4 (sqrt 16))) tolerance))
|
||||
;; (assert (not (< (abs (- 4 (sqrt 15))) tolerance)))
|
||||
|
||||
;; (assert (< (abs (- 3 (sqrt2 9))) tolerance))
|
||||
;; (assert (< (abs (- 4 (sqrt2 16))) tolerance))
|
||||
;; (assert (not (< (abs (- 4 (sqrt2 15))) tolerance)))
|
||||
|
||||
;; (assert (< (abs (- 3 (sqrt3 9))) tolerance))
|
||||
;; (assert (< (abs (- 4 (sqrt3 16))) tolerance))
|
||||
;; (assert (not (< (abs (- 4 (sqrt3 15))) tolerance)))
|
||||
|
||||
|
||||
;; ;;; -----------------
|
||||
;; ;;; factorial
|
||||
;; ;;; -----------------
|
||||
|
||||
;; (define (factorial n)
|
||||
;; (if (= n 1)
|
||||
;; 1
|
||||
;; (* n (factorial (- n 1)))))
|
||||
|
||||
;; (define (factorial2 n)
|
||||
;; (fact-iter 1 1 n))
|
||||
|
||||
;; (define (fact-iter product counter max-count)
|
||||
;; (if (> counter max-count)
|
||||
;; product
|
||||
;; (fact-iter (* counter product) (+ counter 1) max-count)))
|
||||
|
||||
;; (define (factorial3 n)
|
||||
;; (define (iter product counter)
|
||||
;; (if (> counter n)
|
||||
;; product
|
||||
;; (iter (* counter product) (+ counter 1))))
|
||||
|
||||
;; (iter 1 1))
|
||||
|
||||
;; (assert (= (factorial 6) 720))
|
||||
;; (assert (= (factorial2 6) 720))
|
||||
;; (assert (= (factorial3 6) 720))
|
||||
|
||||
;;; ----------------
|
||||
;;; ackermann
|
||||
;;; ----------------
|
||||
|
||||
(define (A m n)
|
||||
(cond ((= m 0) (+ n 1))
|
||||
((= n 0) (A (- m 1) 1))
|
||||
(else (A (- m 1) (A m (- n 1))))))
|
||||
|
||||
;; (define (A m n)
|
||||
;; (if (= m 0)
|
||||
;; (+ n 1)
|
||||
;; (if (= n 0)
|
||||
;; (A (- m 1) 1)
|
||||
;; (A (- m 1) (A m (- n 1))))))
|
||||
|
||||
(assert (= (A 0 0) 1))
|
||||
(assert (= (A 1 2) 4))
|
||||
(assert (= (A 3 1) 13))
|
||||
|
||||
|
||||
;; ;;; ---------------
|
||||
;; ;;; Fibonacci
|
||||
;; ;;; ---------------
|
||||
|
||||
;; (define (fib n)
|
||||
;; (cond ((= n 0) 0)
|
||||
;; ((= n 1) 1)
|
||||
;; (else (+ (fib (- n 1)) (fib (- n 2))))))
|
||||
|
||||
;; (define (fib2 n)
|
||||
;; (fib-iter 1 0 n))
|
||||
|
||||
;; (define (fib-iter a b count)
|
||||
;; (if (= count 0)
|
||||
;; b
|
||||
;; (fib-iter (+ a b) a (- count 1))))
|
||||
|
||||
;; (assert (= (fib 2) 1))
|
||||
;; (assert (= (fib 3) 2))
|
||||
;; (assert (= (fib 4) 3))
|
||||
;; (assert (= (fib 5) 5))
|
||||
;; (assert (= (fib 6) 8))
|
||||
|
||||
;; (assert (= (fib2 2) 1))
|
||||
;; (assert (= (fib2 3) 2))
|
||||
;; (assert (= (fib2 4) 3))
|
||||
;; (assert (= (fib2 5) 5))
|
||||
;; (assert (= (fib2 6) 8))
|
||||
|
||||
;; ;;; ------------------
|
||||
;; ;;; count change
|
||||
;; ;;; ------------------
|
||||
|
||||
;; (define (count-change amount)
|
||||
;; (define (cc amount kinds-of-coins)
|
||||
;; (cond ((= amount 0) 1)
|
||||
;; ((or (< amount 0) (= kinds-of-coins 0)) 0)
|
||||
;; (else (+ (cc amount (- kinds-of-coins 1))
|
||||
;; (cc (- amount (first-denomination kinds-of-coins)) kinds-of-coins)))))
|
||||
|
||||
;; (define (first-denomination kinds-of-coins)
|
||||
;; (cond ((= kinds-of-coins 1) 1)
|
||||
;; ((= kinds-of-coins 2) 5)
|
||||
;; ((= kinds-of-coins 3) 10)
|
||||
;; ((= kinds-of-coins 4) 25)
|
||||
;; ((= kinds-of-coins 5) 50)))
|
||||
|
||||
;; (cc amount 5))
|
||||
|
||||
;; (assert (= (count-change 100) 292))
|
||||
|
||||
;; ;;; --------------------
|
||||
;; ;;; exponentiation
|
||||
;; ;;; --------------------
|
||||
|
||||
;; (define (expt b n)
|
||||
;; (if (= n 0)
|
||||
;; 1
|
||||
;; (* b (expt b (- n 1)))))
|
||||
|
||||
;; (define (expt2 b n)
|
||||
;; (define (expt-iter b counter product)
|
||||
;; (if (= counter 0)
|
||||
;; product
|
||||
;; (expt-iter b (- counter 1) (* b product))))
|
||||
|
||||
;; (expt-iter b n 1))
|
||||
|
||||
;; (define (fast-expt b n)
|
||||
;; (define (even? n)
|
||||
;; (= (% n 2) 0))
|
||||
|
||||
;; (cond ((= n 0) 1)
|
||||
;; ((even? n) (square (fast-expt b (/ n 2))))
|
||||
;; (else (* b (fast-expt b (- n 1))))))
|
||||
|
||||
;; (assert (= (expt 1 2) 1))
|
||||
;; (assert (= (expt 2 2) 4))
|
||||
;; (assert (= (expt 2 3) 8))
|
||||
|
||||
;; (assert (= (expt2 1 2) 1))
|
||||
;; (assert (= (expt2 2 2) 4))
|
||||
;; (assert (= (expt2 2 3) 8))
|
||||
|
||||
;; (assert (= (fast-expt 1 2) 1))
|
||||
;; (assert (= (fast-expt 2 2) 4))
|
||||
;; (assert (= (fast-expt 2 3) 8))
|
||||
|
||||
;; ;;; ----------
|
||||
;; ;;; gcd
|
||||
;; ;;; ----------
|
||||
|
||||
;; (define (gcd a b)
|
||||
;; (if (= b 0)
|
||||
;; a
|
||||
;; (gcd b (% a b))))
|
||||
|
||||
;; (assert (= (gcd 40 6) 2))
|
||||
;; (assert (= (gcd 13 4) 1))
|
||||
|
||||
|
||||
;; ;;; ----------
|
||||
;; ;;; primes
|
||||
;; ;;; ----------
|
||||
|
||||
;; (define (smallest-divisor n)
|
||||
;; (find-divisor n 2))
|
||||
|
||||
;; (define (find-divisor n test-divisor)
|
||||
;; (cond ((> (square test-divisor) n) n)
|
||||
;; ((divides? test-divisor n) test-divisor)
|
||||
;; (else (find-divisor n (+ test-divisor 1)))))
|
||||
|
||||
;; (define (divides? a b)
|
||||
;; (= (% b a) 0))
|
||||
|
||||
;; (define (prime? n)
|
||||
;; (= n (smallest-divisor n)))
|
||||
|
||||
;; (assert (prime? 13))
|
||||
;; (assert (prime? 11))
|
||||
;; (assert (not (prime? 12)))
|
||||
|
||||
|
||||
;;; ----------------------
|
||||
;;; simple integral
|
||||
;;; ----------------------
|
||||
|
||||
;; (define (sum term a next b)
|
||||
;; (if (> a b)
|
||||
;; 0
|
||||
;; (+ (term a) (sum term (next a) next b))))
|
||||
|
||||
;; (define (integral f a b dx)
|
||||
;; (define (add-dx x) (+ x dx))
|
||||
;; (* (sum f (+ a (/ dx 2.0)) add-dx b) dx))
|
||||
|
||||
;; (define (pi-sum a b)
|
||||
;; (define (pi-term x) (/ 1.0 (* x (+ x 2))))
|
||||
;; (define (pi-next x) (+ x 4))
|
||||
;; (sum pi-term a pi-next b))
|
||||
|
||||
;; (assert (< (abs (- (* 8 (pi-sum 1 100)) 3.121595)) 0.0001))
|
||||
;; (assert (< (abs (- (integral cube 0 1 0.02) 0.249950)) 0.0001))
|
||||
|
||||
|
||||
;; ------------------------------------------------------------
|
||||
;; F(x,y) = x(1 + xy)^2 + y(1 − y) + (1 + xy)(1 − y)
|
||||
;; ------------------------------------------------------------
|
||||
|
||||
;; (define (f x y)
|
||||
;; (let ((a (+ 1 (* x y)))
|
||||
;; (b (- 1 y)))
|
||||
;; (+ (* x (square a))
|
||||
;; (* y b)
|
||||
;; (* a b))))
|
||||
|
||||
;; (assert (= (f 0 0) 1))
|
||||
;; (assert (= (f 1 1) 4))
|
||||
|
||||
|
||||
;; ;;; ---------------
|
||||
;; ;;; find zero
|
||||
;; ;;; ---------------
|
||||
|
||||
;; (define (positive? x) (< 0 x))
|
||||
;; (define (negative? x) (< x 0))
|
||||
|
||||
;; (define (search f neg-point pos-point)
|
||||
;; (let ((midpoint (average neg-point pos-point)))
|
||||
;; (if (close-enough? neg-point pos-point)
|
||||
;; midpoint
|
||||
;; (let ((test-value (f midpoint)))
|
||||
;; (cond ((positive? test-value) (search f neg-point midpoint))
|
||||
;; ((negative? test-value) (search f midpoint pos-point))
|
||||
;; (else midpoint))))))
|
||||
|
||||
;; (define (close-enough? x y) (< (abs (- x y)) 0.001))
|
||||
|
||||
;; (assert (close-enough? (search (lambda (x) (- 1 (square x))) -3 3) -1))
|
||||
|
||||
@@ -0,0 +1,58 @@
|
||||
;;
|
||||
;; let testing
|
||||
;;
|
||||
(assert (not (bound? var1)))
|
||||
(assert (not (bound? var2)))
|
||||
(assert (not (bound? var3)))
|
||||
(let ((var1 1)
|
||||
(var2 [1 2 3])
|
||||
(var3 {1 2 3 4}))
|
||||
(assert (bound? var1))
|
||||
(assert (bound? var2))
|
||||
(assert (bound? var3))
|
||||
(assert (= var1 1))
|
||||
(assert (= var2 [1 2 3]))
|
||||
(assert (= var3 {1 2 3 4})))
|
||||
|
||||
(assert (not (bound? var1)))
|
||||
(assert (not (bound? var2)))
|
||||
(assert (not (bound? var3)))
|
||||
|
||||
(assert (= (let ((val 'sym))
|
||||
val)
|
||||
'sym))
|
||||
|
||||
(assert (= (let ()
|
||||
'sym)
|
||||
'sym))
|
||||
;;
|
||||
;; Quasiquote testing
|
||||
;;
|
||||
(assert (= '() `()))
|
||||
|
||||
(assert (= '(1 1 2)
|
||||
`(1 1 2)))
|
||||
|
||||
(assert (= '(1 1 2)
|
||||
`(1 ,1 2)))
|
||||
|
||||
(assert (= '(1 1 2)
|
||||
`(1 ,(- 10 9) 2)))
|
||||
|
||||
(assert (= '(1 1 2)
|
||||
`(1 ,@(list 1 2))))
|
||||
|
||||
(let ((body '(2 3)))
|
||||
(assert (= '(1 2 3)
|
||||
`(1 ,@body))))
|
||||
|
||||
(let ((body '((define a 1)
|
||||
(define b 2)))
|
||||
(imports '()))
|
||||
(let ((expr `(begin ,@(map (lambda (x) `(import ,x)) imports) ,@body)))
|
||||
(assert (= '(begin
|
||||
(define a 1)
|
||||
(define b 2))))
|
||||
(eval expr)
|
||||
(assert (= a 1))
|
||||
(assert (= b 2))))
|
||||
@@ -1,20 +1,20 @@
|
||||
(import "tests/import1.slime")
|
||||
|
||||
(assert (= a 1111))
|
||||
(assert (= (get-a-1) 1111))
|
||||
|
||||
|
||||
(import "tests/import2.slime")
|
||||
|
||||
|
||||
(assert (= a 1111))
|
||||
(assert (= (get-a-1) 1111))
|
||||
(assert (= (get-a-2) 1111))
|
||||
|
||||
(set-a-2 11)
|
||||
|
||||
(assert (= a 11))
|
||||
|
||||
(assert (= (get-a-1) 11))
|
||||
|
||||
(assert (= (get-a-2) 11))
|
||||
(import "tests/import1.slime")
|
||||
|
||||
(assert (= a 1111))
|
||||
(assert (= (get-a-1) 1111))
|
||||
|
||||
|
||||
(import "tests/import2.slime")
|
||||
|
||||
|
||||
(assert (= a 1111))
|
||||
(assert (= (get-a-1) 1111))
|
||||
(assert (= (get-a-2) 1111))
|
||||
|
||||
(set-a-2 11)
|
||||
|
||||
(assert (= a 11))
|
||||
|
||||
(assert (= (get-a-1) 11))
|
||||
|
||||
(assert (= (get-a-2) 11))
|
||||
|
||||
Reference in New Issue
Block a user