Luc Teirlinck <[EMAIL PROTECTED]> 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
_______________________________________________
Emacs-devel mailing list
Emacs-devel@gnu.org
http://lists.gnu.org/mailman/listinfo/emacs-devel
