prelude.golisp

;; primitive type predicates
(define (is? x t)        (== (type-of x) t))
(define (boolean? x)     (is? x 'boolean))
(define (fixnum? x)      (is? x 'fixnum))
(define (bignum? x)      (is? x 'bignum))
(define (flonum? x)      (is? x 'flonum))
(define (number? x)      (if (fixnum? x) #t (if (flonum? x) #t (bignum? x))))
(define (string? x)      (is? x 'string))
(define (symbol? x)      (is? x 'symbol))
(define (pair? x)        (is? x 'pair))
(define (vector? x)      (is? x 'vector))
(define (macro? x)       (is? x 'macro))
(define (function? x)    (is? x 'function))
(define (input-port? x)  (is? x 'input-port))
(define (output-port? x) (is? x 'output-port))
(define (channel? x)     (is? x 'channel))

;; broader type predicates
(define (atom? x) (not (sequence? x)))
(define (sequence? x) (if (vector? x) #t (pair? x)))

;; basic stuff
(define (id x)                          x)
(define (object->boolean x)             (if x #t #f))
(define (not x)                         (if x #f #t))
(define (zero? x)                       (if (== x 0) #t (== x 0.0)))
(define (even? x)                       (= (remainder x 2) 0))
(define (odd? x)                        (not (even? x)))
(define (1- x)                          (fixnum-sub x 1))
(define (1+ x)                          (fixnum-add x 1))
(define (list . xs)                     xs)
(define (null? x)                       (== x ()))
(define (vector . xs)                   (list->vector xs))
(define ((const x) . _)                 x)
(define void                            (const #v))
(define ((compose f g) x)               (f (g x)))
(define ((curry f . first) . rest)      (apply f (append first rest)))
(define ((pred->guard p) x)             (if (p x) x #f))
(define ((guard->pred g) x)             (object->boolean (g x)))
(define (error msg)                     (throw 'error msg))

;; strings
(define string->list (compose vector->list string->vector))
(define list->string (compose vector->string list->vector))

(define (substring s start end) 
  (vector->string (vector-slice (string->vector s) start end)))

(define (string-ref s idx)
  (substring s idx (1+ idx)))

(define (string-append . ss)
  (string-join ss ""))

;; list accessors
(define   caar (compose car car))
(define   cadr (compose car cdr))
(define   cdar (compose cdr car))
(define   cddr (compose cdr cdr))
(define  caaar (compose car caar))
(define  caadr (compose car cadr))
(define  cadar (compose car cdar))
(define  caddr (compose car cddr))
(define  cdaar (compose cdr caar))
(define  cdadr (compose cdr cadr))
(define  cddar (compose cdr cdar))
(define  cdddr (compose cdr cddr))
(define caaaar (compose car caaar))
(define caaadr (compose car caadr))
(define caadar (compose car cadar))
(define caaddr (compose car caddr))
(define cadaar (compose car cdaar))
(define cadadr (compose car cdadr))
(define caddar (compose car cddar))
(define cadddr (compose car cdddr))
(define cdaaar (compose cdr caaar))
(define cdaadr (compose cdr caadr))
(define cdadar (compose cdr cadar))
(define cdaddr (compose cdr caddr))
(define cddaar (compose cdr cdaar))
(define cddadr (compose cdr cdadr))
(define cdddar (compose cdr cddar))
(define cddddr (compose cdr cdddr))

;; list traversal
(define (fold f acc l)
  (if (null? l)
    acc
    (fold f (f (car l) acc) (cdr l))))

(define (filter p l)
  (define (f x acc) (if (p x) (cons x acc) acc))
  (fold f () l))

(define (map f l . ls)
  (if (null? ls)
    (reverse (fold (lambda (x acc) (cons (f x) acc)) () l))
    (map (lambda (xs) (apply f xs)) (apply zip (cons l ls)))))

(define (length l)
  (fold (lambda (_ acc) (1+ acc)) 0 l))

;; list munging
(define (reverse l)
  (fold cons () l))
  
(define (zip l . ls)
  (define (iter acc ls)
    (if (null? (filter null? ls))
      (iter (cons (map car ls) acc) (map cdr ls))
      acc))
  (reverse (iter () (cons l ls))))

(define (append . ls)
  (if (null? ls)
    ()
    (begin
      (set! ls (reverse ls))
      (fold (lambda (l acc) (fold cons acc (reverse l))) (car ls) (cdr ls)))))

;; backquote magic
(define-macro (quasiquote tmplt)
  (if (pair? tmplt)
    (fold (lambda (cell acc)
            (if (pair? cell)
              (if (== (car cell) 'unquote)
                (list 'cons (cadr cell) acc)
                (if (== (car cell) 'unquote-splicing)
                  (if (null? acc)
                    (cadr cell)
                    (list 'append (cadr cell) acc))
                  (list 'cons (list 'quasiquote cell) acc)))
              (list 'cons (list 'quote cell) acc)))
          ()
          (reverse tmplt))
    (list 'quote tmplt)))

;; aux macros
(define-macro (define-gensyms . ss)
  `(begin ,@(map (lambda (s) `(define ,s (gensym))) ss)))

(define-macro (when t . b)
  `(if ,t (begin ,@b) #v))

(define-macro (unless t . b)
  `(when (not ,t) ,@b))

(define-macro (define* . vs)
  `(begin ,@(map (lambda (v) `(define ,v #v)) vs)))

(define-macro (optional args . vs)
  (define-gensyms tmp)
  `(begin ,@(map (lambda (v)
                   `(define ,v (if (null? ,args)
                                 #f
                                 (let ([,tmp (car ,args)])
                                   (set! ,args (cdr ,args))
                                   ,tmp))))
                 vs)))

;; main macro set
(define-macro (let bs . b)
  (define (named-let name bs b)
    `(letrec ([,name (lambda ,(map car bs) ,@b)])
      (,name ,@(map cadr bs))))
  (if (if (null? bs) #t (pair? bs))
    `((lambda ,(map car bs) ,@b) ,@(map cadr bs))
    (named-let bs (car b) (cdr b))))

(define-macro (let* bs . b)
  (fold (lambda (x acc) `(let (,x) ,acc))
        `(begin ,@b)
        (reverse bs)))

(define-macro (letrec bs . b)
  `((lambda ()
    ,@(map (curry list 'define)
           (map car bs)
           (map cadr bs))
    ,@b)))

(define-macro (and . cs)
  (if (null? cs)
    #t
    (if (null? (cdr cs))
      (car cs)
      `(if ,(car cs)
        (and ,@(cdr cs))
        #f))))

(define-macro (or . cs)
  (define-gensyms val)
  (if (null? cs)
    #f
    `(let ([,val ,(car cs)])
      (if ,val
        ,val
        (or ,@(cdr cs))))))

(define-macro (cond . cs)
  (unless (null? cs)
    (let ([c (car cs)])
      (define-gensyms val)
      (if (== (car c) 'else)
        `(begin ,@(cdr c))
        `(if ,(car c)
          (begin ,@(cdr c))
          (cond ,@(cdr cs)))))))

(define-macro (do vars test . cmds)
  (define-gensyms loop)
  `(let ,loop ,(zip (map car vars) (map cadr vars))
    (if ,(car test)
      (begin
        ,@(cdr test))
      (begin
        ,@cmds
        (,loop ,@(map (lambda (var)
                        (if (null? (cddr var))
                          (car var)
                          (caddr var)))
                      vars))))))

;; fix some of the primitive functions
(define-macro (define-wrapped head . body)
  (if (pair? head)
    `(define-wrapped ,(car head) (lambda ,(cdr head) ,@body))
    `(define ,head (let ([,head ,head]) ,@body))))

(define-wrapped (apply f . arglst)
  (set! arglst (reverse arglst))
  (apply f (fold cons (car arglst) (cdr arglst))))
  
(define-wrapped (eval expr . rest)
  (optional rest env)
  (eval expr (if env env (root-environment))))

(define-wrapped (load file . rest)
  (optional rest env)
  (load file (if env env (root-environment))))

(define-wrapped (write x . rest)
  (optional rest pt)
  (write x (if pt pt (standard-output))))

(define-wrapped (display x . rest)
  (optional rest pt)
  (display x (if pt pt (standard-output))))

(define-wrapped (read x . rest)
  (optional rest pt)
  (read x (if pt pt (standard-input))))

(define (newline . pt)
  (apply display "\n" pt))

;; more list stuff
(define* proper-list? improper-list?)
(let ()
  (define (list-type x)
    (cond 
      [(null? x) 'proper]
      [(pair? x) (list-type (cdr x))]
      [else 'improper]))
  (define (proper? x)
    (== (list-type x) 'proper))
  (define (improper? x)
    (and (pair? x)
         (== (list-type x) 'improper)))
  (set! proper-list? proper?)
  (set! improper-list? improper?))

(define list? proper-list?)

;; selection
(define (list-tail ls idx)
  (do ([cur ls (cdr cur)] 
       [x idx (1- x)])
    [(zero? x) cur]))

(define (list-head ls idx)
  (reverse (list-tail (reverse ls) (- (length ls) idx))))

(define (list-ref ls idx)
  (car (list-tail ls idx)))

;; searching
(define (member k ls)
  (do ([cur ls (cdr cur)])
    [(= k (car cur)) cur]))

(define (assoc k ls)
  (do ([cur ls (cdr cur)])
    [(= k (caar cur)) (car cur)]))

;; equality
(define (list=? a b)
  (and (list? a) 
       (list? b)
       (== (length a) (length b))
       (fold (lambda (a+b acc) 
               (and acc
                    (apply = a+b)))
             #t
             (zip a b))))

(define (vector=? a b)
  (define l (vector-length a))
  (and (vector? a)
       (vector? b)
       (== l (vector-length b))
       (let lp ([i 0])
        (cond
          [(== i l) #t]
          [(not (= (vector-ref a i) (vector-ref b i))) #f]
          [else (lp (1+ i))]))))

(define (= a b)
  ((cond 
     [(list? a) list=?]
     [(vector? a) vector=?]
     [else ==])
   a b))

;; numbers
(define* + - * /)
(let ()
  (define ((num-op fix flo) a b)
    (if (and (fixnum? a) (fixnum? b))
      (fix a b)
      (flo (fixnum->flonum a) (fixnum->flonum b))))
  (set! + (num-op fixnum-add flonum-add))
  (set! - (num-op fixnum-sub flonum-sub))
  (set! * (num-op fixnum-mul flonum-mul))
  (set! / (num-op fixnum-div flonum-div)))

;; control
(define (dynamic-wind before thk after)
  (define done #f)
  (before)
  (catch (lambda () (thk) (set! done #t) (after))
         (lambda (k m) (unless done (after)) (throw k m))))

(define (call/ec f)
  (define msg (gensym))
  (catch (lambda () (f (lambda (x) (throw msg x))))
         (lambda (k m) (if (== k msg) m (throw k m)))))

(define (<- ch . v)
  (cond
    [(null? v) (channel-receive ch)]
    [(null? (cdr v)) (channel-send ch (car v))]
    [else (error "<-: wrong number of arguments")]))