prelude.cscm

;;  Copyright (C) 2017  Zaoqi

;;  This program is free software: you can redistribute it and/or modify
;;  it under the terms of the GNU Affero General Public License as published
;;  by the Free Software Foundation, either version 3 of the License, or
;;  (at your option) any later version.

;;  This program is distributed in the hope that it will be useful,
;;  but WITHOUT ANY WARRANTY; without even the implied warranty of
;;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;  GNU Affero General Public License for more details.

;;  You should have received a copy of the GNU Affero General Public License
;;  along with this program.  If not, see <http://www.gnu.org/licenses/>.
(define first car)
(define (second x) (car (cdr x)))
(define (third x) (car (cdr (cdr x))))
(define (fourth x) (car (cdr (cdr (cdr x)))))
(define (add-between xs v)
  (cond
    [(null? xs) '()]
    [(null? (cdr xs)) xs]
    [else (cons (car xs) (cons v (add-between (cdr xs) v)))]))

(define (zero? x) (eq? x 0))
(define (abs x)
  (if (< x 0)
      (- 0 x)
      x))

(define (not x) (if x #f #t))
(defmacro (and . xs)
  (cond
    [(null? xs) #t]
    [(null? (cdr xs)) (car xs)]
    [else (list 'if (car xs)
                (cons 'and (cdr xs))
                #f)]))
(defmacro (or . xs)
  (cond
    [(null? xs) #f]
    [(null? (cdr xs)) (car xs)]
    [else (let ([s (genstr!)])
            `(let ([,s ,(car xs)])
               (if ,s
                   ,s
                   (or ,@(cdr xs)))))]))
(defmacro (let ps . vs)
  (cons (cons 'λ (cons (map first ps) vs))
        (map second ps)))
(defmacro (quasiquote x)
  (define (Q n x)
    (cond
      [(pair? x)
       (let ([f (first x)])
         (cond
           [(eq? f 'unquote)
            (if (zero? n)
                (second x)
                (list 'list ''unquote (Q (- n 1) (second x))))]
           [(and (pair? f) (eq? (first f) 'unquote-splicing))
            (if (zero? n)
                (list 'append (second f) (Q 0 (cdr x)))
                (list 'cons (list 'list ''unquote-splicing (Q (- n 1) (second f))) (Q n (cdr x))))]
           [(eq? f 'quasiquote) (list 'list ''quasiquote (Q (+ n 1) (second x)))]
           [else (list 'cons (Q n f) (Q n (cdr x)))]))]
      [else (list 'quote x)]))
  (Q 0 x))
(define-record-type promise
  (%delay x)
  promise?
  (x %force))
(defmacro (delay x)
  `(%delay (atom! (λ () ,x))))
(define (force x)
  (let ([r (atom-get/set!
            (%force x)
            (λ (v)
              (cond
                [(pair? v) (cons v v)]
                [(not v) (error "force: halted" x)]
                [else (cons v #f)])))])
    (if (pair? r)
        (car r)
        (car (atom-map! (λ (v) (list (r))) (%force x))))))
(define (promise-running? x) (not (atom-get (%force x))))
(define (promise-forced? x) (pair? (atom-get (%force x))))
(defmacro (struct name fs)
  `(define-record-type ,name
     (,name ,@(map (λ (f) (if (pair? f)
                              (car f)
                              f))
                   fs))
     ,(string-append name "?")
     ,@(map (λ (f)
              (if (pair? f) ; #:mutable
                  (let ([f (car f)])
                    (let ([ff (string-append name (string-append "-" f))])
                      `(,f ,ff
                           ,(string-append "set-" (string-append ff "!")))))
                  `(,f ,(string-append name (string-append "-" f))))) fs)))
(struct ERROR (x))
(define (error x) (raise (ERROR x)))
(define (++ . xs)
  (cond
    [(null? xs) ""]
    [(list? (car xs)) (apply ++ (append (car xs) (cdr xs)))]
    [else (string-append (car xs) (apply ++ (cdr xs)))]))
(define symbol? string?)
(define (partition f xs)
  (if (null? xs)
      (cons '() '())
      (let ([r (partition f (cdr xs))])
        (if (f (car xs))
            (cons (cons (car xs) (car r)) (cdr r))
            (cons (car r) (cons (car xs) (cdr r)))))))
(define (filter f xs)
  (if (null? xs)
      '()
      (if (f (car xs))
          (cons (car xs) (filter f (cdr xs)))
          (filter f (cdr xs)))))
(define (foldl f x xs)
  (if (null? xs)
      x
      (foldl f (f (car xs) x) (cdr xs))))