; (load #P"utils")

;;; delay operator
(defpackage :delay-operator
  (:use :cl :utils)
  (:nicknames :dly))

(in-package dly)
                 (export 'delay)
                 (export 'force)
(shadow 'null)   (export 'null)
(shadow 'cons)   (export 'cons)
(shadow 'car)    (export 'car)
(shadow 'cdr)    (export 'cdr)
(shadow 'nthcdr) (export 'nthcdr)
(shadow 'nth)    (export 'nth)
                 (export 'to-list)
                 (export 'enum)
(shadow 'mapcar) (export 'mapcar)
(shadow 'append) (export 'append)

(declaim (inline force null car cdr nth))

(defmacro delay (x)
  (with-gensyms (gval gevaled)
    `(let (,gval ,gevaled)
       (lambda ()
         (if ,gevaled
           ,gval
           (progn
             (setq ,gevaled t)
             (setq ,gval ,x)))))))

(defun force (x) (funcall x))

(defmacro cons (x y)
  `(cl:cons ,x (delay ,y)))

(defun null (z) (cl:null z))

(defun car (z) (cl:car z))
(defun cdr (z)
  (aif (and z (force (cl:cdr z))) it))

(defmacro def-car-cdrs (&rest nums)
  (let* ((variations
          (mapcan (lambda (n) (perm '(a d) n :repeat t))
                  nums))
         (fun-names
           (cl:mapcar (lambda (l) (apply #'mkstr `(c ,@l r)))
                      variations)))
    (dolist (x fun-names) (shadow x))
    (let ((fname-syms (cl:mapcar #'intern fun-names))
          (bodys
           (cl:mapcar (lambda (l)
                        (reduce (lambda (x acc) `(,(symb 'c x 'r) ,acc))
                                l :from-end t :initial-value 'z))
                     variations)))
      `(progn
         ,@(mapcan (lambda (fname body)
                     `((shadow ',fname) (export ',fname)
                       (defun ,fname (z) ,body)))
                      fname-syms bodys)))))


(def-car-cdrs 2 3 4)

(defun nthcdr (n s)
  (if (<= n 0)
    s
    (nthcdr (1- n) (cdr s))))

(defun nth (n s)
  (car (nthcdr n s)))

(defun to-list (stm)
  (labels ((rec (s acc)
             (if (null s)
               (nreverse acc)
               (rec (cdr s)
                    (cl:cons (car s) acc)))))
    (rec stm nil)))

(defun enum (&optional (from 0) (then 1) to)
  (if (and to (or (and (plusp to) (> from to))
                  (and (minusp to) (< from to))))
    nil
    (cons from
          (enum (+ from then) then to))))

(defun mapcar (fn s1 &rest ss)
  (if (some #'null (cl:cons s1 ss))
    nil
    (cons (apply fn (car s1)
                    (cl:mapcar #'car ss))
          (apply #'mapcar fn (cdr s1)
                             (cl:mapcar #'cdr ss)))))

