code.delx.au - gnu-emacs-elpa/blob - packages/myers/myers.el

   1 ;;; myers.el --- Random-access singly-linked lists     -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2016  Free Software Foundation, Inc.
   4
   5 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
   6 ;; Keywords: list, containers
   7 ;; Package-Requires: ((emacs "25"))
   8 ;; Version: 0.1
   9
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; This package implements Eugene W. Myers's "stacks" which are like
  26 ;; standard singly-linked lists, except that they also provide efficient
  27 ;; lookup.  More specifically:
  28 ;;
  29 ;; cons/car/cdr are O(1), while (nthcdr N L) is O(min (N, log L))
  30 ;;
  31 ;; For details, see "An applicative random-access stack", Eugene W. Myers,
  32 ;; 1983, Information Processing Letters
  33 ;; http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.188.9344&rep=rep1&type=pdf
  34
  35 ;;; Code:
  36
  37 (require 'cl-lib)
  38 (require 'seq)
  39
  40 (cl-defstruct (myers
  41                (:copier nil)
  42                (:constructor nil)
  43                (:conc-name myers--)
  44                (:constructor myers--cons (car cdr skip-distance skip)))
  45   (car nil :read-only t)
  46   (cdr nil :read-only t :type (or null myers))
  47   ;; Contrary to Myers's presentation, we index from the top of the stack,
  48   ;; and we don't store the total length but the "skip distance" instead.
  49   ;; This makes `cons' slightly faster, and better matches our use for
  50   ;; debruijn environments.
  51   (skip-distance nil :read-only t :type integer)
  52   (skip nil :read-only t :type (or null myers)))
  53
  54 (defun myers-cons (car cdr)
  55   "Create a new Myers cons, give it CAR and CDR as components, and return it.
  56 This like `cons' but for Myers's lists."
  57   (if (null cdr)
  58       (myers--cons car cdr 1 cdr)
  59     (let ((s1 (myers--skip-distance cdr))
  60           (cddr (myers--skip cdr)))
  61       (if (null cddr)
  62           (myers--cons car cdr 1 cdr)
  63         (let ((s2 (myers--skip-distance cddr))
  64               (cdddr (myers--skip cddr)))
  65           (if (<= s2 s1)
  66               (myers--cons car cdr (+ 1 s1 s2) cdddr)
  67             (myers--cons car cdr 1 cdr)))))))
  68
  69 (defun myers-list (&rest objects)
  70   "Return a newly created list with specified arguments as elements."
  71   (let ((list nil))
  72     (dolist (x (nreverse objects))
  73       (setq list (myers-cons x list)))
  74     list))
  75
  76 ;; FIXME: Should myers-car/cdr just defer to myers--car/cdr, or should they
  77 ;; reproduce car/cdr's behavior more faithfully and return nil when the arg
  78 ;; is nil?
  79 (defalias 'myers-car #'myers--car)
  80 (defalias 'myers-cdr #'myers--cdr)
  81
  82 (pcase-defmacro myers-cons (car cdr)
  83   `(cl-struct myers (car ,car) (cdr ,cdr)))
  84
  85 (defun myers-nthcdr (n list)
  86   "Take `myers-cdr' N times on LIST, return the result."
  87   (while (and (> n 0) list)
  88     (let ((s (myers--skip-distance list)))
  89       (if (<= s n)
  90           (setq n (- n s) list (myers--skip list))
  91         (setq n (- n 1) list (myers--cdr list)))))
  92   list)
  93
  94 ;; This operation would be more efficient using Myers's choice of keeping
  95 ;; the length (instead of the skip-distance) in each node.
  96 (cl-defmethod seq-length ((seq myers))
  97   (let ((n 0))
  98     (while seq
  99       (cl-incf n (myers--skip-distance seq))
 100       (setq seq (myers--skip seq)))
 101     n))
 102
 103 (cl-defmethod seq-elt ((seq myers) n)
 104   (let ((l (myers-nthcdr n seq)))
 105     (when l (myers--car l))))
 106
 107
 108 (cl-defmethod seq-do (fun (seq myers))
 109   (while seq
 110     (funcall fun (myers--car seq))
 111     (setq seq (myers--cdr seq))))
 112
 113 (cl-defmethod seqp ((_seq myers)) t)
 114
 115 (cl-defmethod seq-copy ((seq myers))
 116   (let ((elts ()))
 117     (while seq
 118       (push (myers--car seq) elts)
 119       (setq seq (myers--cdr seq)))
 120     (dolist (elt elts)
 121       (setq seq (myers-cons elt seq)))
 122     seq))
 123
 124 (cl-defmethod seq-subseq ((seq myers) start &optional end)
 125   (when (< start 0)
 126     (let ((nstart (+ (seq-length seq) start)))
 127       (if (< nstart 0)
 128           (signal 'args-out-of-range (list seq start))
 129         (setq start nstart))))
 130   (setq seq (myers-nthcdr start seq))
 131   (if (null end)
 132       (seq-copy seq)
 133     (let ((nend (if (>= end 0)
 134                     (- end start)
 135                   (+ end (seq-length seq)))))
 136       (if (< nend 0)
 137           (signal 'args-out-of-range (list seq end))
 138         (setq end nend)))
 139     (let ((elts ())
 140           (res ()))
 141       (dotimes (_ end)
 142         (push (myers--car seq) elts)
 143         (setq seq (myers--cdr seq)))
 144       (dolist (elt elts)
 145         (setq res (myers-cons elt res)))
 146       res)))
 147
 148 (cl-defmethod seq-empty-p ((_seq myers)) nil)
 149
 150 (cl-defmethod seq-reverse ((seq myers))
 151   (let ((res ()))
 152     (while seq
 153       (setq res (myers-cons (myers--car seq) res))
 154       (setq seq (myers--cdr seq)))
 155     res))
 156
 157 (defun myers-find (pred list)
 158   "Find the first element of LIST for which PRED returns non-nil.
 159 \"Binary\" search, assuming the list is \"sorted\" (i.e. all elements after
 160 this one also return true).
 161 Return the node holding that element (or nil, if none found)."
 162   (while
 163       (when list
 164         (if (funcall pred (myers--car list))
 165             nil
 166           (let ((l2 (myers--skip list)))
 167             (setq list (myers--cdr list))
 168             (if (eq l2 list)
 169                 t
 170               (while
 171                   (and l2 (not (funcall pred (myers--car l2)))
 172                        (progn
 173                          (setq list (myers--cdr l2))
 174                          (setq l2 (myers--skip l2))
 175                          t))))
 176             t))))
 177   list)
 178
 179 ;; (* Find the last node for which the predicate `p' is false.
 180 ;;  * "Binary" search, assuming the list is "sorted" (i.e. all elements after
 181 ;;  * this one also return true).  *)
 182 ;; let rec findcdr p l =
 183 ;;   let rec findcdr2 last l1 l2 =
 184 ;;     match l1,l2 with
 185 ;;     | _, (Mcons (x, l1, _, l2) as l) when not (p x) -> findcdr2 (Some l) l1 l2
 186 ;;     | l, _ -> findcdr1 last l
 187 ;;   and findcdr1 last l =
 188 ;;     match l with
 189 ;;      | Mnil -> last
 190 ;;      | Mcons (x, _, _, _) when p x -> last
 191 ;;      | Mcons (_, l1, _, l2) -> findcdr2 (Some l) l1 l2
 192 ;;   in findcdr1 None l
 193
 194
 195 (provide 'myers)
 196 ;;; myers.el ends here