Re: lists.texi

[Thien-Thi Nguyen]

Luc Teirlinck <address@hidden> writes:

> Apparently these timings are not very fixed.  In a freshly started
> Emacs, my proposed version took 12 seconds (instead of earlier 23) and
> the abstract versions 40 seconds (instead of 51).  This gives a
> mysterious gain of 11 seconds for both.  But now my proposed version
> runs 3.33 times faster than the abstract ones, instead of earlier 2.2.

(curmudgeon-mode) i have a hard enough time wrapping my head around
whole numbers, like 1 and 0 -- all this stuff after the decimal point is
lost on me.  when things are slow that's just an excuse for a nap!

but fwiw, in the spirit of not discouraging the nimble mind, below is
some code that you can perhaps use/tweak to exercise rings in a less
clinical environment (to put a nice name on a messy playpen... :-).

the curious will note that ewoc.el documentation is as yet unwritten.
is anyone looking into that?  can it wait until after next release?

thi

___________________________________________________________________________
;;; WORK-IN-PROGRESS  WORK-IN-PROGRESS  WORK-IN-PROGRESS  WORK-IN-PROGRESS
;;; WORK-IN-PROGRESS  WORK-IN-PROGRESS  WORK-IN-PROGRESS  WORK-IN-PROGRESS
;;; WORK-IN-PROGRESS  WORK-IN-PROGRESS  WORK-IN-PROGRESS  WORK-IN-PROGRESS

;;; edb.el --- EDB 2.x

;; Copyright (C) 2005 Thien-Thi Nguyen

;; EDB is distributed under the terms of the GNU General Public License.

;; EDB is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY.  No author or distributor accepts responsibility to anyone
;; for the consequences of using it or for whether it serves any particular
;; purpose or works at all, unless he says so in writing.  Refer to the GNU
;; General Public License for full details.

;; Everyone is granted permission to copy, modify and redistribute EDB, but
;; only under the conditions described in the GNU General Public License.  A
;; copy of this license is supposed to have been given to you along with EDB
;; so you can know your rights and responsibilities.  It should be in a file
;; named COPYING.  If not, write to the Free Software Foundation, Inc.,
;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA for a copy.
;; Among other things, the copyright notice and this notice must be preserved
;; on all copies.

;;; Commentary:

;; Naming convention: "edb--" means "internal"; "edb-" means "public".
;; If all goes well (everything is useful), we will relax this convention
;; (and consider everything public).

;;; Code:

(eval-when-compile (require 'cl))


;;; sequential read and write

(defvar edb--*sequential-i/o*           ; alist
  `((read-line . ,(lambda (finish)
                    (let (rec recs)
                      (while (< (progn
                                  (setq rec (read (current-buffer)))
                                  (skip-syntax-forward "^()")
                                  (point))
                                finish)
                        (push rec recs))
                      recs)))))


;;; connection

(defvar edb--*schema-schema*
  '((single (:valid-keys
             :name :require
             :fields :fieldtype :field-separator
             :record-separator :record-separator-function
             :read-record :write-record :record-defaults
             :post-last-record :choose-display :display :report
             :summary-format :substitutions
             :every-change-function
             :field-setter :first-change-function
             :field-priorities
             :enumerated-type :tagged-setup
             :displaytype
             :before-display
             :data)
            (:valid-options)))
  "Alist of sub-alists controlling how a schema is handled.
In the sub-alist, valid keys are:

:valid-keys -- list of acceptable keys
:valid-options -- list of acceptable options")

(defun edb--validate-schema (type options schema)
  (let* ((ent (or (cdr (assq type edb--*schema-schema*))
                  (error "Invalid schema type: %S" type)))
         (valid-keys (mapcar (lambda (k-ent)
                               (if (consp k-ent)
                                   (car k-ent)
                                 k-ent))
                             (cdr (assq :valid-keys ent))))
         (valid-options (cdr (assq :valid-options ent))))
    ;; check plist form
    (let ((ls schema))
      (while ls
        (unless (keywordp (car ls))
          (error "Not a keyword: %S" (car ls)))
        (setq ls (cddr ls))))
    ;; check key membership
    (let ((ls schema))
      (while ls
        (unless (memq (car ls) valid-keys)
          (error "Not a valid key: %S" (car ls)))
        (setq ls (cddr ls))))
    ;; check option membership
    (let ((ls options))
      (while ls
        (unless (memq (car ls) valid-options)
          (error "Not a valid option: %S" (car ls)))
        (setq ls (cdr ls)))))
  ;; todo: other checks
  schema)

(defmacro edb--with-callable-connection (name &rest body)
  `(flet ((,name (&rest args) (apply ,name args)))
     ,@body))

(defun edb--connect (control-file)
  (let ((conn (lexical-let (V F)        ; todo: use obarray
                (lambda (command &rest args)
                  (case command
                    ;; it's not worthy of emacs if it's not extensible
                    (:V! (setq V (apply 'plist-put V args)))
                    (:F! (setq F (apply 'plist-put F args)))
                    (t (let (it)
                         (if (setq it (plist-get F command))
                             (apply it args)
                           (plist-get V command)))))))))
    (edb--with-callable-connection conn
      (with-temp-buffer
        (let (emacs-lisp-mode-hook)
          (emacs-lisp-mode))
        ;; determine schema metainfo
        (let ((reality (insert-file-contents control-file))
              meta)
          (unless (and (< 4 (cadr reality))
                       (string= ":EDB " (buffer-substring-no-properties 1 6))
                       (consp (setq meta (progn (goto-char 6)
                                                (read (current-buffer))))))
            (error "Does not seem to be an EDB control file"))
          ;; maintain lameness for the present
          (unless (equal '(single) meta)
            (error "Not lame enough: %S" meta))
          (conn :V! :schema-type (car meta))
          (conn :v! :schema-options (cdr meta))
          (delete-region (point-min) (point)))
        ;; determine schema
        (let (start kw val schema)
          (while (< (point) (point-max))
            (when (keywordp (setq start (point)
                                  kw (read (current-buffer))))
              (push kw schema)
              (setq val (read (current-buffer)))
              (if (memq kw '(:display :report :data))
                  (let* ((pls (if (eq t val)
                                  (list :name t :coding t :EOTB ":EOTB")
                                val))
                         (datap (eq :data kw))
                         (tb-start (progn (forward-line 1) (point)))
                         (name (plist-get pls :name))
                         (coding (or (plist-get pls :coding) t))
                         (EOTB (or (plist-get pls :EOTB) ":EOTB"))
                         tb-finish)
                    (unless (or
                             ;; data text blocks are anonymous
                             datap
                             (eq t name) (stringp name))
                      (error "Bad %S name: %S" kw name))
                    (unless (symbolp coding)
                      (error "Bad %S coding: %S" kw coding))
                    (unless (stringp EOTB)
                      (error "Bad %S EOTB: %S" kw EOTB))
                    (setq tb-finish (if (not (re-search-forward
                                              (concat "^" EOTB "$")
                                              (point-max) 1))
                                        (point-max)
                                      (forward-line 1)
                                      (match-beginning 0)))
                    (if datap
                        (let* ((seqr (plist-get pls :seqr))
                               (f (or (cdr (assq seqr edb--*sequential-i/o*))
                                      (error "Bad :seqr func: %S" seqr))))
                          (save-excursion
                            (goto-char tb-start)
                            (plist-put pls :records (funcall f tb-finish))))
                      (plist-put pls :text (buffer-substring-no-properties
                                            tb-start tb-finish)))
                    (if datap
                        (conn :V! (pop schema) pls)
                      (push pls schema)))
                (forward-comment 1)
                (push val schema))
              (delete-region start (point))))
          ;; normalize, validate and stash
          (conn :V! :schema (edb--validate-schema (conn :schema-type)
                                                  (conn :schema-options)
                                                  (nreverse schema))))))
    conn))


;;; viewing

(require 'ewoc)

(defun FUTURE/ewoc-delete-node (ewoc node)
  (ewoc--delete-node-internal ewoc node))

(defun FUTURE/ewoc-point-min (ewoc)
  (ewoc-location (ewoc--header ewoc)))

;; (defun FUTURE/ewoc-point-max (ewoc)
;;   (let ((footer (ewoc--footer ewoc)))
;;     ;; add 1 because ewoc.el inserts a gratuitous newline, sigh.
;;     (+ (ewoc-location footer) (length (ewoc-data footer)) 1)))

(defstruct (edb--OBSERVER
            (:type vector)
            (:constructor edb--alloc-observer-struct)
            (:conc-name edb--O-))
  nick                ;; string
  ewoc                ;; see ewoc.el
  cur                 ;; "current node"; (ewoc-data CUR) => record
  nodes               ;; hash: record to node
  rlens               ;; hash: record to display length
  foc                 ;; (funcall FOC beg end)
  unf                 ;; (funcall UNF beg end)
  km                  ;; key map
  followers           ;; list of observers for motion synch
  ;; etc...
  )

(defun edb--observer-focus (observer)
  (let* ((cur (edb--O-cur observer))
         (beg (ewoc-location cur))
         (end (+ beg (gethash (ewoc-data cur) (edb--O-rlens observer))))
         (foc (edb--O-foc observer)))
    (add-text-properties beg end '(face font-lock-string-face))
    (when foc (funcall foc beg end))))

(defun edb--observer-unfocus (observer &optional node)
  (let* ((bye (or node (edb--O-cur observer)))
         (beg (ewoc-location bye))
         (end (+ beg (gethash (ewoc-data bye) (edb--O-rlens observer))))
         (unf (edb--O-unf observer)))
    (when unf (funcall unf beg end))
    (remove-text-properties beg end '(face font-lock-string-face))))

(defun edb--observer-move-to-node (observer cur node &optional already)
  (unless (eq node cur)
    (edb--observer-unfocus observer)
    (setf (edb--O-cur observer) (ewoc-goto-node (edb--O-ewoc observer) node))
    (edb--observer-focus observer))
  (push observer already)
  (let ((followers (edb--O-followers observer))
        record)
    (when followers
      (setq record (ewoc-data node))
      (dolist (f followers)
        (unless (memq f already)
          (save-excursion
            (with-current-buffer (ewoc-buffer (edb--O-ewoc f))
              (edb--observer-move-to-node
               f t (gethash record (edb--O-nodes f)) already))))))))

(defsubst edb--observer-at-point (&optional noerror)
  (or (get-text-property (point) :edb--O)
      (unless noerror
        (error "No observer here"))))

(defun edb--observer-move-prev ()
  (interactive)
  (let* ((ob (edb--observer-at-point))
         (ewoc (edb--O-ewoc ob))
         (cur (edb--O-cur ob)))
    (edb--observer-move-to-node ob cur (or (ewoc-prev ewoc cur)
                                           (ewoc-nth ewoc -1)))))

(defun edb--observer-move-next ()
  (interactive)
  (let* ((ob (edb--observer-at-point))
         (ewoc (edb--O-ewoc ob))
         (cur (edb--O-cur ob)))
    (edb--observer-move-to-node ob cur (or (ewoc-next ewoc cur)
                                           (ewoc-nth ewoc 0)))))

(defun z/SYNCHRONOUS-kill (record observers)
  (let (window pos ewoc node buf)
    (dolist (ob observers)
      (setq ewoc (edb--O-ewoc ob)
            node (gethash record (edb--O-nodes ob))
            buf (ewoc-buffer ewoc))
      (with-current-buffer buf
        ;; begin hmmm
        ;; this uses the "public interface" only, but that's lame.
        ;;-  (ewoc-filter
        ;;-   ewoc (lambda (rec)
        ;;-          (let ((zonkp (eq record rec)))
        ;;-            (when (and zonkp (eq record (ewoc-data (edb--O-cur ob))))
        ;;-              (edb--observer-move-next))
        ;;-            (not zonkp))))
        ;; this is the way it SHOULD be (ewoc.el needs to change).
        (when (eq node (edb--O-cur ob))
          (unless (and (eq node (ewoc-nth ewoc 0))
                       (not (ewoc-next ewoc node)))
            (goto-char (ewoc-location node))
            (edb--observer-move-next)))
        (FUTURE/ewoc-delete-node ewoc node)
        ;; end hmmm
        (unless (marker-buffer (setq pos (ewoc-location (edb--O-cur ob))))
          (setf (edb--O-cur ob) nil
                pos (FUTURE/ewoc-point-min ewoc)))
        (goto-char pos)
        (when (setq window (get-buffer-window buf))
          (set-window-point window pos))))))

(defun edb--make-observer (ls render nick buf manyp)
  (let* ((count (length ls))
         (map (make-sparse-keymap))
         (ob (edb--alloc-observer-struct
              :nick nick
              :nodes (make-hash-table :size count :weakness t)
              :rlens (make-hash-table :size count :weakness 'key)
              :foc (unless manyp
                     (lambda (beg end)
                       (remove-text-properties beg end '(invisible t))))
              :unf (unless manyp
                     (lambda (beg end)
                       (add-text-properties beg end '(invisible t))))
              :km map)))
    (with-current-buffer buf
      (setf (edb--O-ewoc ob)
            (ewoc-create
             (lexical-let ((render render)
                           (ob ob))
               (lambda (record)
                 (let ((start (point))
                       (s (funcall render record)))
                   (insert (propertize s 'keymap (edb--O-km ob) :edb--O ob))
                   (puthash record
                            ;; 1+ because ewoc.el inserts a
                            ;; gratuitous newline, sigh.
                            (1+ (- (point) start))
                            (edb--O-rlens ob)))))
             (format "%s %s\nTOP" (make-string 20 ?-) nick)
             "BOT"))
      ;; init
      (let ((ewoc (edb--O-ewoc ob))
            (nodes (edb--O-nodes ob))
            node)
        ;; fill ewoc
        (dolist (record ls)
          (puthash record (setq node (ewoc-enter-last ewoc record)) nodes)
          (unless manyp
            (edb--observer-unfocus ob node)))
        ;; set current
        (setf (edb--O-cur ob) (ewoc-locate ewoc))
        (ewoc-goto-node ewoc (edb--O-cur ob))
        (edb--observer-focus ob))
      ;; keymap (text property)
      (define-key map "p"                   'edb--observer-move-prev)
      (define-key map [remap previous-line] 'edb--observer-move-prev)
      (define-key map "n"                   'edb--observer-move-next)
      (define-key map [remap next-line]     'edb--observer-move-next)
      ob)))

(defstruct (edb--OBSERVER-GROUP
            (:type vector)
            (:constructor edb--alloc-observer-group-struct)
            (:conc-name edb--OG-))
  i                ;; index
  ring             ;; see ring.el
  last-point       ;; (perhaps unuseful)
  last-buffer      ;; (perhaps unuseful)
  timer            ;; set when updating observations falls behind too much
  changed          ;; hash: record to ticks
  display          ;; hash: record to ticks (perhaps unuseful)
  )

(defun edb--observer-group-enter (group p)
  (let ((ob (save-excursion (goto-char p) (edb--observer-at-point t))))
    (unless ob
      (setf (point) (next-single-char-property-change p :edb--O)
            ob (edb--observer-at-point t)))
    (when ob
      (goto-char
       (setf (edb--OG-i group) (let ((ring (edb--OG-ring group)))
                                 (do ((i 0 (1+ i)))
                                     ((eq ob (ring-ref ring i)) i)))
             (edb--OG-last-buffer group) (current-buffer)
             (edb--OG-last-point group) (ewoc-location (edb--O-cur ob)))))))

(defun edb--observer-group-redisplay (group)
  (let ((changes (edb--OG-changed group))
        nodes invs ewoc node curp)
    (dolist (ob (ring-elements (edb--OG-ring group)))
      (setq nodes (edb--O-nodes ob)
            invs nil
            curp nil)
      (maphash (lambda (record u)
                 (when (setq node (gethash record nodes))
                   (push node invs)
                   (unless curp
                     (setq curp (and (eq node (edb--O-cur ob)) node)))))
               changes)
      (when invs
        (with-current-buffer (ewoc-buffer (setq ewoc (edb--O-ewoc ob)))
          (when curp (edb--observer-unfocus ob))
          (apply 'ewoc-invalidate ewoc invs)
          (mapc (lambda (node)
                  (edb--observer-unfocus ob node))
                invs)
          (when curp (edb--observer-focus ob)))))
    (clrhash changes)))

(defun edb--observer-group-note-change (group record)
  (incf (gethash record (edb--OG-changed group) -1))
  (cond ((edb--OG-timer group))
        ((input-pending-p)
         (setf (edb--OG-timer group)
               (run-with-idle-timer
                0.1 nil (lambda (group)
                          (edb--observer-group-redisplay group)
                          (setf (edb--OG-timer group) nil))
                group)))
        (t (edb--observer-group-redisplay group))))

(defun edb--observer-group-ob-with-nick (group nick)
  (let ((ring (edb--OG-ring group))
        ob)
    (do ((i 0 (1+ i)))
        ((string= nick (edb--O-nick (setq ob (ring-ref ring i)))) ob))))

(defun edb--observer-group-move-to-next-observer (group)
  (interactive)
  (let ((ob (ring-ref (edb--OG-ring group) (incf (edb--OG-i group)))))
    (ewoc-goto-node (edb--O-ewoc ob) (edb--O-cur ob))
    (setf (edb--OG-last-buffer group) (current-buffer)
          (edb--OG-last-point group) (point))))

(defvar z/OG nil)                       ; observer group

(defun z/summary-buffer (name count
                         ;;manyp ls render name
                               )
  (with-current-buffer (get-buffer-create name)
    (buffer-disable-undo)
    (setq major-mode 'EDB2-HACK
          mode-name "EDB2 HACK"
          truncate-lines t)
    (use-local-map
     (let ((map (make-sparse-keymap)))
       (suppress-keymap map)
       (define-key map "\C-i"
         (lambda () (interactive)
           (if (edb--observer-at-point t)
               (edb--observer-group-move-to-next-observer z/OG)
             (edb--observer-group-enter z/OG (point)))))
       (define-key map "u"
         (lambda () (interactive)
           (let ((ob (edb--observer-at-point t))
                 record)
             (if (not ob)
                 (message "Use TAB to move to (and select) an observer")
               (incf (aref (setq record (ewoc-data (edb--O-cur ob))) 1))
               (edb--observer-group-note-change z/OG record)))))
       (define-key map "k"
         (lambda () (interactive)
           (let* ((ob (edb--observer-at-point t))
                  ewoc cur)
             (if (not ob)
                 (message "Use TAB to move to (and select) an observer")
               (z/SYNCHRONOUS-kill
                (ewoc-data (edb--O-cur ob))
                (ring-elements (edb--OG-ring z/OG)))
               (if (setq ewoc (edb--O-ewoc ob)
                         cur (edb--O-cur ob))
                   (ewoc-goto-node ewoc (edb--O-cur ob))
                 (goto-char (FUTURE/ewoc-point-min ewoc)))))))
       map))
    (set (make-local-variable 'z/OG)
         (edb--alloc-observer-group-struct
          :i 0
          :ring (make-ring count)
          :changed (make-hash-table :size count :weakness 'key)))
    (current-buffer)))

(defun z/add-observer (group buffer manyp ls render name)
  (with-current-buffer buffer
    (goto-char (point-min))
    (ring-insert (edb--OG-ring group)
                 (edb--make-observer ls render name buffer manyp))))


;;; testing

'(defun test:edb--connect (control-file)
  (interactive "fControl file: ")
  (let ((conn (edb--connect control-file)))
    (edb--with-callable-connection conn
      (switch-to-buffer "*scratch*")
      (goto-char (point-min))
      (insert (format "\n%s %S %S\n"
                      control-file
                      (conn :schema-type)
                      (conn :schema-options)))
      (pp (conn :schema) (current-buffer))
      (pp (conn :data) (current-buffer)))))

(defun test:edb--viewing ()
  (interactive)
  (let* ((ls (mapcar (lambda (raw)
                       (vector raw -1))
                     '("lsakdjf" "sssss" "d d d" "42" "foobar" "baz"
                       "a" "b" "c" "d" "e" "f" "g")))
         (line (lambda (record)
                 (let ((magic (aref record 1)))
                   (if (> 0 magic)
                       "---"
                     (format "%3d%s\t%-8s\t%s"
                             magic
                             (if (zerop (% magic 10))
                                 "  !"
                               "")
                             (aref record 0)
                             (make-string magic ?|))))))
         (pict (lexical-let ((line line))
                 (lambda (record)
                   (if (> 6 (length (aref record 0)))
                       (funcall line record)
                     (let* ((field (mapconcat
                                    (lambda (n)
                                      (let ((sp (- 33 (/ n 2))))
                                        (concat "##"
                                                (make-string sp 32)
                                                (make-string n ?#)
                                                (make-string sp 32)
                                                "##")))
                                    '(8 16 32 64 48 32 32 16 8)
                                    "\n"))
                            (len (length field))
                            (magic (aref record 1))
                            x)
                       (when (< 0 magic)
                         (dotimes (i magic)
                           (aset field
                                 (if (= 10 (aref field (setq x (random len))))
                                     (1- x)
                                   x)
                                 ?-)))
                       (concat field " (" (aref record 0) ")"))))))
         (buf (z/summary-buffer "ooo" 6)))
    (switch-to-buffer buf)
    (z/add-observer z/OG buf   t ls pict "minus ten")
    (z/add-observer z/OG buf nil ls pict "minus one")
    (z/add-observer z/OG buf nil ls line "zero")
    (z/add-observer z/OG buf   t ls line "o1")
    (z/add-observer z/OG buf nil ls line "o2")
    (z/add-observer z/OG buf   t ls line "o3"))
  (let ((o1 (edb--observer-group-ob-with-nick z/OG "o1")))
    (setf (edb--O-followers o1) (list (edb--observer-group-ob-with-nick
                                       z/OG "o3")))
    (define-key (edb--O-km o1) " "
      (lambda () (interactive)
        (let* ((o1 (edb--observer-group-ob-with-nick z/OG "o1"))
               (o2 (edb--observer-group-ob-with-nick z/OG "o2"))
               (o3 (edb--observer-group-ob-with-nick z/OG "o3"))
               (now (case (random 5)
                      (0 nil)
                      (1 (list o2))
                      (2 (list o3))
                      (3 (list o2 o3))
                      (4 (list o3 o2)))))
          (setf (edb--O-followers o1) now)
          (message "%s followers now: %s"
                   (edb--O-nick o1)
                   (if now
                       (mapconcat 'edb--O-nick now " AND ")
                     "(none)")))))))

;;; ttn-sez: local-vars-block-zonkable
;;; Local Variables:
;;; auto-save-default: nil
;;; make-backup-files: nil
;;; End:

;;; edb.el ends here