slime/bin/pre.slime

(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
condition is true.

{{{example_start}}}
(when (not ())
  (print \"Hello \")
  (print \"from \")
  (print \"when!\"))

(when ()
  (print \"Goodbye \")
  (print \"World!\"))
{{{example_end}}}
"
  (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
condition 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 "
{{{example_start}}}
(construct-list
  i <- '(1 2 3 4 5)
  yield (* i i))
{{{example_end}}}

(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)
  if (= 0 (% i 2))
  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) '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 (apply fun seq)
;;   :doc "Applies the function to the sequence, as in calls the function with
;; ithe sequence as arguemens."
;;   `(eval (pair ,fun ,seq)))

(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)
    ;; we have the fun-name, the param names and the types, lets go:
    ;;
    ;; first check if there is already a generic-<name>-map
    (let ((generic-map-name (string->symbol
                             (concat-strings "generic-" (symbol->string fun-name) "-map"))))
      (unless (bound? generic-map-name)
        (define generic-map-name (create-hash-map)))
      (hm/set! generic-map-name types (eval `(,lambda ,names @body)))
      ;; now check if the generic procedure already exists
      (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.

{{{example_start}}}
(define a (list 1 2 3 4))
(print (end a))
{{{example_end}}}
"
  (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.

{{{example_start}}}
(define a (list 1 2 3 4))
(print (last a))
{{{example_end}}}
"
  (first (end seq)))

(define (extend seq elem)
  :doc "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)
  :doc "Extends a list with the given element, by putting it in
the (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
with (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
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 (:from 0) to)
  :doc "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)
  :doc "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 (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
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)
  :doc "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 (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
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 (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 (print (:sep " ") (:end "\n") . args)
;;   "A  wrapper for  the built-in  function [[=print=]]  that accepts  a
;; variable number of arguments and also provides keywords for specifying
;; the printed separators  (=sep=) between the arguments  and what should
;; be printed after the last argument (=end=)."
;;   (define (print-inner args)
;;     (if args
;;         (begin
;;          (print (first args))
;;          (when (rest args)
;;            (print sep))
;;          (print-inner (rest args)))
;;       ; else
;;       (print end)))

;;   (print-inner args)
;;   ())



;; (generic-extend (+ v1 :vector v2 :vector)
;;    (assert (= (vector-length v1)
;;               (vector-length v2)))
;;    (vector (+ (vector-ref v1 0)
;;               (vector-ref v2 0))))


;; (unless (bound? generic-+-map)
;;   (set! generic-+-map (create-hash-map)))
;; (hm/set! generic-+-map '(:vector :vector) (lambda (v1 v2)
;;                                             (assert (= (vector-length v1)
;;                                                        (vector-length v2)))
;;                                             (vector (+ (vector-ref v1 0)
;;                                                        (vector-ref v2 0)))))
;; (hm/set! generic-+-map '(:string :string) (lambda (v1 v2) (concat-strings v1 v2)))

;; (let ((define-it
;;         (lambda (backup)
;;           (set! + (set-type!
;;                    (lambda args (let ((fun (hm/get-or-nil generic-+-map (map type args))))
;;                                   (if fun (apply fun args)
;;                                     (backup args))))
;;                    :generic-procedure)))))
;;   (if (bound? +)
;;       (let ((exisiting-fun +))
;;         (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-it (lambda (args) (apply orig-proc args)))))
;;     (define-it (lambda (args) (error :generic-lookup "no overloads found")))))