317 lines
9.1 KiB
Plaintext
317 lines
9.1 KiB
Plaintext
(define-syntax (pe expr)
|
|
`(printf ',expr "evaluates to" ,expr))
|
|
|
|
(define-syntax (when condition :rest body)
|
|
"Doc String for `when'"
|
|
(if (= (rest body) ())
|
|
`(if ,condition @body)
|
|
`(if ,condition (begin @body))))
|
|
|
|
(define-syntax (unless condition :rest body)
|
|
(if (= (rest body) ())
|
|
`(if ,condition nil @body)
|
|
`(if ,condition nil (begin @body))))
|
|
|
|
(define-syntax (n-times times action)
|
|
"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 :rest 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 :rest clauses)
|
|
(define (rec clauses)
|
|
(if (= nil clauses)
|
|
nil
|
|
(if (= (first (first clauses)) 'else)
|
|
(begin
|
|
(if (not (= () (rest clauses)))
|
|
(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 (define-special name-and-args :rest body)
|
|
`(define ,(first name-and-args) (special-lambda ,(rest name-and-args) @body)))
|
|
|
|
(define-syntax (construct-list :rest body)
|
|
"
|
|
(construct-list
|
|
i <- '(1 2 3 4 5)
|
|
yield (* i i))
|
|
|
|
(construct-list
|
|
i <- '(1 2 3 4)
|
|
j <- '(A B)
|
|
yield (pair i j))
|
|
|
|
(construct-list
|
|
i <- '(1 2 3 4 5 6 7 8)
|
|
when (evenp i)
|
|
yield i)
|
|
|
|
"
|
|
(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) 'when)
|
|
`(if ,(first (rest body)) ,(rec (rest (rest body)))))
|
|
((= (first body) 'yield)
|
|
(first (rest body)))
|
|
(else (error "Not a do-able expression"))))
|
|
|
|
(rec body))
|
|
|
|
(define-syntax (apply fun seq)
|
|
"Applies the funciton to the sequence, as in calls the function with
|
|
ithe sequence as arguemens."
|
|
`(eval (pair ,fun ,seq)))
|
|
|
|
|
|
(define-syntax (define-package name :rest body)
|
|
`(define ,(string->symbol (concat-strings (symbol->string name) "->"))
|
|
((lambda ()
|
|
@body
|
|
(set-type
|
|
(special-lambda (:rest args)
|
|
(let ((op (first args))
|
|
(args (rest args)))
|
|
(cond ((= op 'pi) 3.14159265)
|
|
(else (try (apply op args)
|
|
(error "The package does not contain this operation"))))))
|
|
:package)))))
|
|
|
|
|
|
(define (nil? x)
|
|
"Checks if the argument is nil."
|
|
(= x nil))
|
|
|
|
(define (number? x)
|
|
"Checks if the argument is a number."
|
|
(= (type x) :number))
|
|
|
|
(define (symbol? x)
|
|
"Checks if the argument is a symbol."
|
|
(= (type x) :symbol))
|
|
|
|
(define (keyword? x)
|
|
"Checks if the argument is a keyword."
|
|
(= (type x) :keyword))
|
|
|
|
(define (pair? x)
|
|
"Checks if the argument is a pair."
|
|
(= (type x) :pair))
|
|
|
|
(define (string? x)
|
|
"Checks if the argument is a string."
|
|
(= (type x) :string))
|
|
|
|
(define (lambda? x)
|
|
"Checks if the argument is a function."
|
|
(= (type x) :dynamic-function))
|
|
|
|
(define (special-lambda? x)
|
|
"Checks if the argument is a macro."
|
|
(= (type x) :dynamic-macro))
|
|
|
|
(define (built-n-function? x)
|
|
"Checks if the argument is a built-in function."
|
|
(= (type x) :built-in-function))
|
|
|
|
(define (end seq)
|
|
"Returns the last pair in the sqeuence."
|
|
(if (or (nil? seq) (not (pair? (rest seq))))
|
|
seq
|
|
(end (rest seq))))
|
|
|
|
(define (last seq)
|
|
"Returns the (first) of the last (pair) of the given sequence."
|
|
(first (end seq)))
|
|
|
|
(define (extend seq elem)
|
|
"Extends a list with the given element, by putting it in
|
|
the (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)
|
|
"Extends a list with the given element, by putting it in
|
|
the (rest) of the last element of the sequence."
|
|
(printf "addr of (end seq)" (addr-of (end seq)))
|
|
(if (pair? seq)
|
|
(let ((e (end seq)))
|
|
(printf "addr if e inner" (addr-of e))
|
|
(mutate e (pair (first e) elem))
|
|
seq))
|
|
elem)
|
|
|
|
(define (append seq elem)
|
|
"Appends an element to a sequence, by extendeing the list
|
|
with (pair elem nil)."
|
|
(extend seq (pair elem ())))
|
|
|
|
(define (length seq)
|
|
"Returns the length of the given sequence."
|
|
(if (nil? seq)
|
|
0
|
|
(+ 1 (length (rest seq)))))
|
|
|
|
(define (increment val)
|
|
"Adds one to the argument."
|
|
(+ val 1))
|
|
|
|
(define (decrement val)
|
|
"Subtracts one from the argument."
|
|
(- val 1))
|
|
|
|
|
|
;; (defmacro for (@symbol @from @to :rest @for-body)
|
|
;; "Designed to resemble a C style for loop. It takes a symbol as
|
|
;; well as its starting number and end number and executes the
|
|
;; @for-body with the defined symbol for all numbers between @from
|
|
;; to @to, where @to is exclusive."
|
|
;; (if (< (eval @from) (eval @to))
|
|
;; (macro-define @op incr)
|
|
;; (if (> (eval @from) (eval @to))
|
|
;; (macro-define @op decr)
|
|
;; (macro-define @op nil)))
|
|
;; (when @op
|
|
;; (macro-define (eval @symbol) (eval @from))
|
|
;; (eval (pair begin @for-body))
|
|
;; (eval (extend (list for @symbol (@op @from) @to) @for-body))))
|
|
|
|
(define (range :keys from :defaults-to 0 to)
|
|
"Returns a sequence of numbers starting with the number defined
|
|
by 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 :keys from :defaults-to 0 to)
|
|
"Returns a sequence of numbers starting with the number defined
|
|
by the key 'from' and ends with the number defined in 'to'."
|
|
(define result (list (copy from)))
|
|
(define head result)
|
|
(mutate from (increment from))
|
|
(while (< from to)
|
|
(begin
|
|
(mutate head (pair (first head) (pair (copy from) nil)))
|
|
(define head (rest head))
|
|
(mutate from (increment from))))
|
|
result)
|
|
|
|
(define (map fun seq)
|
|
"Takes a function and a sequence as arguments and returns a new
|
|
sequence which contains the results of using the first sequences
|
|
elemens as argument to that function."
|
|
(if (nil? seq)
|
|
seq
|
|
(pair (fun (first seq))
|
|
(map fun (rest seq)))))
|
|
|
|
(define (reduce fun seq)
|
|
"Takes a function and a sequence as arguments and applies the
|
|
function to the argument sequence. This only works correctly if
|
|
the given function accepts a variable amount of parameters. If
|
|
your funciton is limited to two arguments, use `reduce-binary'
|
|
instead."
|
|
(apply fun seq))
|
|
|
|
(define (reduce-binary fun seq)
|
|
"Takes a function and a sequence as arguments and applies the
|
|
function to the argument sequence. reduce-binary applies the
|
|
arguments `pair-wise' which means it works with binary functions
|
|
as compared to `reduce'."
|
|
(if (nil? (rest seq))
|
|
(first seq)
|
|
(fun (first seq)
|
|
(reduce-binary fun (rest seq)))))
|
|
|
|
(define (filter fun seq)
|
|
"Takes a function and a sequence as arguments and applies the
|
|
function to every value in the sequence. If the result of that
|
|
funciton application returns a truthy value, the original value is
|
|
added 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 (nil? l1) (nil? 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 (printf :keys sep :defaults-to " " end :defaults-to "\n" :rest args)
|
|
"A wrapper for the built-in (print) that accepts a variable number
|
|
of arguments and also provides keywords for specifying the printed
|
|
separators between the arguments and what should be printed after the
|
|
las argument."
|
|
(define printf-quoted (special-lambda (:keys sep end :rest args)
|
|
(if (nil? args)
|
|
(begin (print (eval end)) nil)
|
|
(begin
|
|
(print (first args))
|
|
(unless (nil? (rest args))
|
|
(print (eval sep)))
|
|
(eval (pair printf-quoted
|
|
(extend (list :sep (eval sep) :end (eval end)) (rest args))))))))
|
|
|
|
(eval (pair printf-quoted (extend (list :sep (eval sep) :end (eval end)) args))))
|