WIP SRFI-1 implementation

erfi-srfi-1-temporary.el

;;; erfi-srfi-1.el --- SRFI-1 -*- lexical-binding: t -*-

;; Copyright (C) 2014  Ken Okada

;; Author: Ken Okada <keno.ss57@gmail.com>
;; Keywords: extensions, lisp
;; URL: https://github.com/kenoss/erfi
;; Package-Requires: ((emacs "24"))

;; Apache License, Version 2.0

;;; Commentary:

;; 

;;; Code:



(eval-when-compile
  (setq byte-compile-warnings '(not cl-functions))
  (require 'cl))


(eval-when-compile
 (require 'erfi-macros)
 (erfi:use-short-macro-name))
(require 'cl-lib)


;; Constructors

(defun erfi:xcons (d a)
  (cons a d))

(defalias 'erfi:cons* 'list*)

(defun erfi:make-list (n &optional fill)
  (progn
    (when (< n 0)
      (error "erfi:make-list: negative length given: %s\n" n))
    (rlet1 rs '()
      (while (< 0 n)
        (push fill rs)
        (decf n)))))

(defun erfi:list-tabulate (n init-proc)
  (progn
    (when (< n 0)
      (error "erfi:make-list: negative length given: %s\n" n))
    (setq n (1- n))
    (rlet1 rs '()
      (while (<= 0 n)
        (push (funcall init-proc n) rs)
        (decf n)))))

(defalias 'erfi:list-copy 'copy-sequence)

(defun erfi:circular-list (x &rest xs)
;  `#1=(,@xs . #1#))
  (let1 ys (cons x xs)
    (rlet1 head ys
      (while (not (null (cdr ys)))
        (pop ys))
      (setcdr ys head))))

(defun erfi:iota (count &optional start step)
  (let ((x (or start 0))
        (d (or step 1)))
    (let1 rs '()
      (while (< 0 count)
        (push x rs)
        (incf x d)
        (decf count))
      (nreverse rs))))




;; Predicates

(defmacro erfi:circular-list-p:aux (f x)
  `(if (not (consp ,x))
       nil
       (let ((sub-list (list ,x))
             (y (cdr ,x)))
         (while (and (consp y)
                     (not (erfi:any1 (cut 'eq y <>) sub-list)))
           (push y sub-list)
           (pop y))
         ,(funcall f 'y))))

(defun erfi:proper-list-p (x)
  (erfi:circular-list-p:aux (lambda (y) `(null ,y)) x))
(defun erfi:circular-list-p (x)
  (erfi:circular-list-p:aux (lambda (y) `(consp ,y)) x))
(defun erfi:dotted-list-p (x)
  (erfi:circular-list-p:aux (lambda (y) `(not (or (null ,y) (consp ,y)))) x))

;; (defun erfi:list= (elt= &rest xss)
;;   (cond ((>= 1 (length xss))
;;          t)
;;         ((let1 len (length (car xss))
;;            (not (erfi:every1 (lambda (xs) (eq len (length xs))) (cdr xss))))
;;          nil)
;;         (t
;;          (erfi:let outer-iter ((xss xss))
;;            (if (null (car xss))
;;                t
;;                (erfi:let inner-iter ((ys (mapcar 'car xss)))
;;                  (if (null (cdr ys))
;;                      (outer-iter (mapcar 'cdr xss))
;;                      (and (funcall elt= (car ys) (cadr ys))
;;                           (inner-iter (cdr ys))))))))))
(defun erfi:list= (elt= &rest xss)
  (if (let1 len (length (car xss))
        (not (erfi:every1 (lambda (xs) (eq len (length xs))) (cdr xss))))
      nil
      (erfi:let outer-iter ((xss xss))
        (if (null (cdr xss))
            t
            (erfi:let inner-iter ((xs (car xss))
                                  (ys (cadr xss)))
              (if (null xs)
                  (outer-iter (cdr xss))
                  (and (funcall elt= (car xs) (car ys))
                       (inner-iter (cdr xs) (cdr ys)))))))))

; pair? null-list? not-pair? ...


;; Selectors

(defun erfi:list-ref (clist n)
  (if (< n 0)
      (error "argument out of range: %s" n)
      (nth n clist)))

;; (defun erfi:take! (x i)
;;   (if (zerop i)
;;       '()
;;       (let1 y x
;;         (while (and (consp y)
;;                     (not (= i 1)))
;;           (pop y)
;;           (decf i))
;;         (if (= i 1)
;;             (progn
;;               (setcdr y '())
;;               x)
;;             (error (concat "erfi:take: input list is too short (expected at least %s elements, "
;;                            "but only %s elements long): %s\n")
;;                    i (length x) x)))))
(defmacro erfi:split-at!:aux (name x i f)
  `(if (zerop ,i)
       '()
       (let1 y ,x
         (while (and (consp y)
                     (not (= ,i 1)))
           (pop y)
           (decf i))
         (if (= ,i 1)
             ,(funcall f x 'y)
             (error ,(concat "%s: input list is too short (expected at least %s elements, "
                             "but only %s elements long): %s\n")
                    name ,i (length ,x) ,x)))))

(defun erfi:take! (x i)
  (erfi:split-at!:aux 'erfi:take! x i
                      (lambda (x y)
                        `(progn
                           (setcdr ,y '())
                           ,x)
                        )))

(defun erfi:split-at! (x i)
  (erfi:split-at!:aux 'erfi:split-at! x i
                      (lambda (x y)
                        `(rlet1 r (list ,x (cdr ,y))
                           (setcdr ,y '())))))

(defun erfi:drop-right! (flist i)
  (let1 j (- (length flist) i)
    (cond ((or (< j 0) (< i 0))
           (error "argument out of range: %s\n" i))
          ((zerop j)
           '())
          (t
           (let1 y flist
             (while (not (= j 1))
               (pop y)
               (decf j))
             (setcdr y '())
             flist)))))

(defun erfi:split-at! (x i)
  (if (zerop i)
      '()
      (let1 y x
        (while (and (consp y)
                    (not (= i 1)))
          (pop y)
          (decf i))
        (if (= i 1)
            (progn
              (setcdr y '())
              ( ; IMCOMPLETE
            (error (concat "erfi:split: input list is too short (expected at least %s elements, "
                           "but only %s elements long): %s\n")
                   i (length x) x)))))))


(defun erfi:last (pair)
  (let1 x pair
    (when (not (consp x))
      (error "erfi:last: pair required: %s" x))
    (while (consp (cdr x))
      (pop x))
    (car x)))
(defun erfi:last-pair (pair)
  (let1 x pair
    (when (not (consp x))
      (error "erfi:last-pair: pair required: %s" x))
    (while (consp (cdr x))
      (pop x))
    x))



;; Others

(defun erfi:concatenate (xss)
  (apply 'append xss))
(defun erfi:concatenate! (xss)
  (apply 'nconc xss))















; IMCOMPLETE
(defun erfi:append-map (proc xs)
  (apply 'append (mapcar proc xs)))


(ert-deftest erfi:srfi-1:others-test ()
  (should (equal (erfi:iota 10000)
                 (erfi:concatenate (mapcar 'list (erfi:iota 10000)))))
  (should (equal (erfi:iota 10000)
                 (erfi:concatenate! (mapcar 'list (erfi:iota 10000)))))

  )




; IMCOMPLETE
(defalias 'erfi:alist-cons 'cl-acons)

(defun erfi:alist-copy (alist)
  (let1 res '()
    (while (not (null alist))
      (push (cons (caar alist) (cdar alist)) res)
      (pop alist))
    (nreverse res)))

(defun erfi:alist-delete (key alist &optional key=)
  "Return a copy of ALIST (as list) if KEY does not appear."
  (let ((key= (or key= 'equal))
        (res '()))
    (while (not (null alist))
      (when (not (funcall key= key (caar alist)))
        (push (car alist) res))
      (pop alist))
    (nreverse res)))
(defun erfi:alist-delete! (key alist &optional key=)
  (let1 key= (or key= 'equal)
    (while (and (not (null alist))
                (funcall key= key (caar alist)))
      (pop alist))
    (rlet1 head alist
      (while (not (null (cdr alist)))
        (if (funcall key= key (caadr alist))
            (setcdr alist (cddr alist))
            (pop alist))))))

(defun erfi:alist-update (key value alist &optional key=)
  (acons key value
         (erfi:alist-delete key alist key=)))
(defun erfi:alist-update! (key value alist &optional key=)
  (let1 pair (erfi:find (let1 key= (or key= 'equal)
                          (lambda (x) (funcall key= key (car x))))
                        alist)
    (if pair
        (progn
          (setcdr pair value)
          alist)
        (acons key value alist))))


(defun erfi:find (pred clist)
  (let1 res (erfi:find-tail pred clist)
    (if res
        (car res)
        nil)))
(defun erfi:find-tail (pred clist)
  (if (funcall pred (car clist))
      clist
      (let1 xs clist
        (while (and (not (null (cdr xs)))
                    (not (funcall pred (cadr xs))))
          (pop xs))
        (cdr-safe xs))))


(defmacro erfi:filter:aux (xs pred-exp)
  `(let1 res '()
     (while (not (null ,xs))
       (when ,pred-exp
         (push (car ,xs) res))
       (pop ,xs))
     (nreverse res)))
(defun erfi:filter (pred xs)
  (erfi:filter:aux xs (funcall pred (car xs))))
(defun erfi:remove (pred xs)
  (erfi:filter:aux xs (not (funcall pred (car xs)))))



(provide 'erfi-srfi-1)
;;; erfi-srfi-1.el ends here