[lice @ big huge rearrange. add hanoi. fix extended-command prefix bug.]
authortailor <sabetts@vcn.bc.ca>
Thu, 10 May 2007 14:45:58 +0000 (10 14:45 +0000)
committertailor <sabetts@vcn.bc.ca>
Thu, 10 May 2007 14:45:58 +0000 (10 14:45 +0000)
59 files changed:
configure.ac
lice.asd [deleted file]
src/Makefile.in [new file with mode: 0644]
src/all.lisp [moved from all.lisp with 100% similarity]
src/buffer-local.lisp [moved from buffer-local.lisp with 100% similarity]
src/buffer.lisp [moved from buffer.lisp with 97% similarity]
src/casefiddle.lisp [moved from casefiddle.lisp with 100% similarity]
src/charset.lisp [new file with mode: 0644]
src/clisp-render.lisp [moved from clisp-render.lisp with 94% similarity]
src/clisp.lisp [moved from clisp.lisp with 100% similarity]
src/cmds.lisp [moved from cmds.lisp with 100% similarity]
src/commands.lisp [moved from commands.lisp with 100% similarity]
src/custom.lisp [moved from custom.lisp with 100% similarity]
src/data-types.lisp [moved from data-types.lisp with 99% similarity]
src/debug.lisp [moved from debug.lisp with 100% similarity]
src/debugger.lisp [moved from debugger.lisp with 76% similarity]
src/editfns.lisp [moved from editfns.lisp with 87% similarity]
src/edmacro.lisp [moved from edmacro.lisp with 100% similarity]
src/elisp.lisp [new file with mode: 0644]
src/files.lisp [moved from files.lisp with 100% similarity]
src/frame.lisp [moved from frame.lisp with 100% similarity]
src/global.lisp [moved from global.lisp with 85% similarity]
src/help.lisp [moved from help.lisp with 100% similarity]
src/indent.lisp [moved from indent.lisp with 86% similarity]
src/insdel.lisp [moved from insdel.lisp with 100% similarity]
src/intervals.lisp [moved from intervals.lisp with 100% similarity]
src/keyboard.lisp [moved from keyboard.lisp with 83% similarity]
src/keymap.lisp [moved from keymap.lisp with 100% similarity]
src/lice.asd [new file with mode: 0644]
src/lisp/lisp-indent.lisp [moved from lisp-indent.lisp with 100% similarity]
src/lisp/lisp-mode.lisp [moved from lisp-mode.lisp with 100% similarity]
src/lisp/paragraphs.lisp [moved from paragraphs.lisp with 100% similarity]
src/lisp/simple.lisp [moved from simple.lisp with 94% similarity]
src/lisp/subr.lisp [moved from subr.lisp with 81% similarity]
src/load.lisp [moved from load.lisp with 100% similarity]
src/main.lisp [moved from main.lisp with 100% similarity]
src/major-mode.lisp [moved from major-mode.lisp with 100% similarity]
src/make-image.lisp [moved from make-image.lisp with 100% similarity]
src/mcl-load.lisp [moved from mcl-load.lisp with 100% similarity]
src/mcl-render.lisp [moved from mcl-render.lisp with 96% similarity]
src/minibuffer.lisp [moved from minibuffer.lisp with 100% similarity]
src/movitz-render.lisp [moved from movitz-render.lisp with 95% similarity]
src/package.lisp [moved from package.lisp with 100% similarity]
src/play/dissociate.lisp [new file with mode: 0644]
src/play/doctor.lisp [moved from doctor.lisp with 100% similarity]
src/play/hanoi.lisp [new file with mode: 0644]
src/recursive-edit.lisp [moved from recursive-edit.lisp with 100% similarity]
src/render.lisp [moved from render.lisp with 97% similarity]
src/search.lisp [moved from search.lisp with 92% similarity]
src/subprocesses.lisp [moved from subprocesses.lisp with 100% similarity]
src/syntax.lisp [moved from syntax.lisp with 100% similarity]
src/textmodes/fill.lisp [new file with mode: 0644]
src/textmodes/text-mode.lisp [moved from text-mode.lisp with 100% similarity]
src/textprop.lisp [moved from textprop.lisp with 92% similarity]
src/tty-render.lisp [moved from tty-render.lisp with 96% similarity]
src/undo.lisp [moved from undo.lisp with 100% similarity]
src/window.lisp [moved from window.lisp with 96% similarity]
src/wm.lisp [moved from wm.lisp with 100% similarity]
src/wrappers.lisp [moved from wrappers.lisp with 100% similarity]

index ece9585..50ec594 100644 (file)
@@ -45,4 +45,4 @@ AC_MSG_NOTICE([Using $LISP at $LISP_PROGRAM])
 # Checks for typedefs, structures, and compiler characteristics.
 
 # Checks for library functions.
-AC_OUTPUT(Makefile)
+AC_OUTPUT(Makefile src/Makefile)
diff --git a/lice.asd b/lice.asd
deleted file mode 100644 (file)
index 5c04e5e..0000000
--- a/lice.asd
+++ /dev/null
@@ -1,53 +0,0 @@
-;; -*- lisp -*-
-
-#+sbcl (require 'sb-posix)
-
-(load "package.lisp")
-
-(defsystem :lice 
-  :depends-on (#-clisp cl-ncurses cl-ppcre)
-  :components ((:file "wrappers")
-              (:file "global")
-              (:file "custom")
-               (:file "commands")
-               (:file "data-types")
-              (:file "keymap" :depends-on ("global"))
-               (:file "casefiddle")
-              (:file "subprocesses" :depends-on ("wrappers" "commands"))
-               (:file "buffer-local" :depends-on ("data-types"))
-              (:file "buffer" :depends-on ("data-types" "buffer-local" "commands" "wrappers" "global"))
-              (:file "intervals" :depends-on ("data-types"))
-              (:file "textprop" :depends-on ("intervals" "global"))
-               (:file "search" :depends-on ("buffer"))
-               (:file "frame" :depends-on ("data-types"))
-              (:file "window" :depends-on ("buffer" "search" "commands" "frame" "data-types"))
-               (:file "render" :depends-on ("frame" "window"))
-               (:file "wm" :depends-on ("data-types" "window" "frame"))
-
-               ;; from this point on there are warnings because of two-way dependencies
-               (:file "insdel" :depends-on ("intervals" #|"undo"|# "buffer"))
-               (:file "cmds" :depends-on ("keymap" "insdel"))
-              (:file "editfns" :depends-on ("buffer" "insdel" "textprop" "cmds"))
-               (:file "undo" :depends-on ("commands" "window"))
-              (:file "syntax" :depends-on ("buffer"))
-              (:file "major-mode" :depends-on ("keymap" "syntax"))
-              (:file "keyboard" :depends-on ("commands" "keymap" "subprocesses" "render"))
-              (:file "debugger" :depends-on ("commands" "major-mode"))
-              (:file "recursive-edit" :depends-on ("keyboard" "render" "debugger"))
-              (:file "minibuffer" :depends-on ("buffer" "window" "recursive-edit" "wm"))
-              (:file "files" :depends-on ("buffer" "buffer-local" "commands" "custom"))
-              (:file "help" :depends-on ("buffer" "commands"))
-              (:file "debug" :depends-on ("buffer" "commands"))
-              #+sbcl (:file "tty-render" :depends-on ("buffer" "window" "frame" "render"))
-               #+clisp (:file "clisp-render" :depends-on ("buffer" "window" "frame" "render"))
-              (:file "main" :depends-on ("buffer" "major-mode" #+sbcl "tty-render" #+clisp "clisp-render"))
-               ;; the following are files outside of lice-base
-              (:file "subr" :depends-on ("commands" "buffer"))
-              (:file "simple" :depends-on ("subr" "commands" "keymap" "major-mode" "custom" "editfns"))
-              (:file "indent" :depends-on ("subr" "simple" "editfns"))
-              (:file "lisp-mode" :depends-on ("indent" "simple"))
-              (:file "lisp-indent" :depends-on ("lisp-mode" "indent" "simple"))
-               (:file "paragraphs" :depends-on ("simple"))
-               (:file "text-mode" :depends-on ("simple" "paragraphs"))
-               (:file "doctor" :depends-on ("simple" "paragraphs" "text-mode"))
-               ))
diff --git a/src/Makefile.in b/src/Makefile.in
new file mode 100644 (file)
index 0000000..d924b72
--- /dev/null
@@ -0,0 +1,19 @@
+# choose your lisp and appropriate lisp_opts
+LISP=@LISP_PROGRAM@
+
+clisp_OPTS=-K full -on-error exit -i ~/.clisprc ./make-image.lisp
+sbcl_OPTS=--load ./make-image.lisp
+
+LISP_OPTS= $(@LISP@_OPTS)
+
+# This is copied from the .asd file. It'd be nice to have the list in
+# one place, but oh well.
+FILES=package.lisp wrappers.lisp global.lisp custom.lisp commands.lisp data-types.lisp keymap.lisp casefiddle.lisp subprocesses.lisp buffer-local.lisp buffer.lisp intervals.lisp textprop.lisp search.lisp frame.lisp window.lisp render.lisp wm.lisp insdel.lisp cmds.lisp editfns.lisp undo.lisp syntax.lisp major-mode.lisp keyboard.lisp debugger.lisp recursive-edit.lisp minibuffer.lisp files.lisp help.lisp debug.lisp tty-render.lisp clisp-render.lisp main.lisp lisp/subr.lisp lisp/simple.lisp indent.lisp lisp/lisp-mode.lisp lisp/lisp-indent.lisp lisp/paragraphs.lisp textmodes/text-mode.lisp play/doctor.lisp play/hanoi.lisp
+
+all: lice
+
+lice: $(FILES)
+       $(LISP) $(LISP_OPTS)
+
+clean:
+       rm -f *.fasl *.fas *.lib lice
similarity index 100%
rename from all.lisp
rename to src/all.lisp
similarity index 100%
rename from buffer-local.lisp
rename to src/buffer-local.lisp
similarity index 97%
rename from buffer.lisp
rename to src/buffer.lisp
index 9cf5896..1a4021e 100644 (file)
@@ -576,9 +576,16 @@ means that other_buffer is more likely to choose a relevant buffer."
   (setf *buffer-list* (delete buffer *buffer-list* :test #'eq))
   (push buffer *buffer-list*))
 
+(defun buffer-read-only ()
+"Non-nil if this buffer is read-only."
+  (slot-value (current-buffer) 'read-only))
+
+(defun (setf buffer-read-only) (value)
+  (setf (slot-value (current-buffer) 'read-only) (and value t)))
+
 (defun barf-if-buffer-read-only ()
   "Signal a `buffer-read-only' error if the current buffer is read-only."
-  (when (buffer-read-only (current-buffer))
+  (when (buffer-read-only)
     (signal 'buffer-read-only)))
 
 (defun bufferp (object)
@@ -657,6 +664,17 @@ its value may not be a list of functions.")
 Linefeed indents to this column in Fundamental mode.")
 (make-variable-buffer-local 'left-margin)
 
+(define-buffer-local truncate-lines nil
+  "*Non-nil means do not display continuation lines.
+Instead, give each line of text just one screen line.
+
+Note that this is overridden by the variable
+`truncate-partial-width-windows' if that variable is non-nil
+and this buffer is not full-frame width.")
+(make-variable-buffer-local 'truncate-lines)
+
+
+
 (defun make-buffer-string (start end props &optional (buffer (current-buffer)))
   "Making strings from buffer contents.
 
similarity index 100%
rename from casefiddle.lisp
rename to src/casefiddle.lisp
diff --git a/src/charset.lisp b/src/charset.lisp
new file mode 100644 (file)
index 0000000..8567701
--- /dev/null
@@ -0,0 +1,67 @@
+(in-package "LICE")
+
+(defun define-charset ()
+  (error "unimplemented"))
+
+(defun generic-character-list ()
+  (error "unimplemented"))
+
+(defun get-unused-iso-final-char ()
+  (error "unimplemented"))
+
+(defun declare-equiv-charset ()
+  (error "unimplemented"))
+
+(defun find-charset-region ()
+  (error "unimplemented"))
+
+(defun find-charset-string ()
+  (error "unimplemented"))
+
+(defun make-char-internal ()
+  (error "unimplemented"))
+
+(defun split-char ()
+  (error "unimplemented"))
+
+(defun char-charset ()
+  (error "unimplemented"))
+
+(defun charset-after (&optional (pos (pt)))
+  "Return charset of a character in the current buffer at position POS.
+If POS is nil, it defauls to the current point.
+If POS is out of range, the value is nil."
+  (error "unimplemented"))
+
+(defun iso-charset ()
+  (error "unimplemented"))
+
+(defun char-valid-p ()
+  (error "unimplemented"))
+
+(defun unibyte-char-to-multibyte ()
+  (error "unimplemented"))
+
+(defun multibyte-char-to-unibyte ()
+  (error "unimplemented"))
+
+(defun char-bytes ()
+  (error "unimplemented"))
+
+(defun char-width ()
+  (error "unimplemented"))
+
+(defun string-width ()
+  (error "unimplemented"))
+
+(defun char-direction ()
+  (error "unimplemented"))
+
+;; (defun string ()
+;;   (error "unimplemented"))
+
+(defun setup-special-charsets ()
+  (error "unimplemented"))
+
+
+
similarity index 94%
rename from clisp-render.lisp
rename to src/clisp-render.lisp
index aaa1db5..3426969 100644 (file)
@@ -51,7 +51,7 @@ hardware.")
           (type fixnum y start))
   (let ((display (frame-2d-double-buffer frame))
        (linear (frame-double-buffer frame)))
-    (clear-line-between window y start (1- (window-width window)) frame)
+    (clear-line-between window y start (1- (window-width window nil)) frame)
     ;; draw the seperator
     (when (window-seperator window)
       (putch #\| (+ (window-x window) (1- (window-width window t))) y window frame))))
@@ -81,12 +81,12 @@ the text properties present."
     ;; Special case: when the buffer is empty
     (if (= (buffer-size (window-buffer w)) 0)
        (progn 
-         (dotimes (y (window-height w))
+         (dotimes (y (window-height w nil))
            (clear-to-eol y 0 w frame))
          (setf cursor-x 0
                cursor-y 0))
       (let ((end (loop named row
-                      for y below (window-height w)
+                      for y below (window-height w nil)
                       for line from (window-top-line w) below cache-size
                       ;; return the last line, so we can erase the rest
                       finally (return-from row y)
@@ -99,7 +99,7 @@ the text properties present."
                            ;; setup the display properties.
                            (turn-on-attributes (window-buffer w) bp frame)
                            (loop named col
-                               for x below (window-width w) do
+                               for x below (window-width w nil) do
                                (progn
                                  ;; Skip the gap
                                  (when (= p (buffer-gap-start buf))
@@ -126,18 +126,18 @@ the text properties present."
                                    (incf p)
                                    (incf bp))))))))
        ;; Check if the bottom of the window needs to be erased.
-       (when (< end (1- (window-height w)))
-         (loop for i from end below (window-height w) do
+       (when (< end (1- (window-height w nil)))
+         (loop for i from end below (window-height w nil) do
                (clear-to-eol i 0 w frame)))))
     ;; Update the mode-line if it exists. FIXME: Not the right place
     ;; to update the mode-line.
     (when (buffer-local '*mode-line-format* (window-buffer w))
       (update-mode-line (window-buffer w))
-      (putstr (truncate-mode-line (window-buffer w) (window-width w))
+      (putstr (truncate-mode-line (window-buffer w) (window-width w nil))
              0 (window-height w nil) w frame)
       ;; don't forget the seperator on the modeline line
       (when (window-seperator w)
-       (putch #\| (+ (window-x w) (window-width w)) (window-height w) w frame)))
+       (putch #\| (+ (window-x w) (window-width w nil)) (window-height w nil) w frame)))
     (reset-line-state w)
     ;; Set the cursor at the right spot
     (values cursor-x cursor-y)))
similarity index 100%
rename from clisp.lisp
rename to src/clisp.lisp
similarity index 100%
rename from cmds.lisp
rename to src/cmds.lisp
similarity index 100%
rename from commands.lisp
rename to src/commands.lisp
similarity index 100%
rename from custom.lisp
rename to src/custom.lisp
similarity index 99%
rename from data-types.lisp
rename to src/data-types.lisp
index 6eb982f..7a8a5a2 100644 (file)
@@ -69,7 +69,7 @@
    (name :type string :initarg :name :accessor buffer-name)
    (mode-line-string :type string :initform "" :accessor buffer-mode-line-string)
    (modified :type boolean :initform nil :accessor buffer-modified-p)
-   (read-only :type boolean :initform nil :accessor buffer-read-only)
+   (read-only :type boolean :initform nil)
    (tick :type integer :initform 0 :accessor buffer-modified-tick :documentation
         "The buffer's tick counter. It is incremented for each change
 in text.")
similarity index 100%
rename from debug.lisp
rename to src/debug.lisp
similarity index 76%
rename from debugger.lisp
rename to src/debugger.lisp
index 548a942..9bf7562 100644 (file)
   (when (get-buffer "*debugger*")
     (kill-buffer (get-buffer "*debugger*")))
   (invoke-restart (find-restart 'recursive-edit-top-level)))
+
+(defcommand toggle-debug-on-error ()
+  "Toggle whether to enter Lisp debugger when an error is signaled.
+In an interactive call, record this option as a candidate for saving
+by \"Save Options\" in Custom buffers."
+  (setf *debug-on-error* (not *debug-on-error*)))
+
+(defcommand toggle-debug-on-quit ()
+  "Toggle whether to enter Lisp debugger when C-g is pressed.
+In an interactive call, record this option as a candidate for saving
+by \"Save Options\" in Custom buffers."
+  (setf *debug-on-quit* (not *debug-on-quit*)))
similarity index 87%
rename from editfns.lisp
rename to src/editfns.lisp
index 984b3b6..166234b 100644 (file)
@@ -376,15 +376,21 @@ and insert the result."
   (dolist (o objects)
     (insert-move-point (current-buffer) o)))
 
-(defun insert-buffer-substring (buffer start end)
+(defun insert-buffer-substring (buffer &optional (start (point-min)) (end (point-max)))
   "Insert before point a substring of the contents of buffer.
 buffer may be a buffer or a buffer name.
 Arguments start and end are character positions specifying the substring.
 They default to the values of (point-min) and (point-max) in buffer."
-  (let* ((buf (get-buffer buffer))
-        (s (buffer-substring start end)))
-    (with-current-buffer buf
-      (insert s))))
+  (check-number-coerce-marker start)
+  (check-number-coerce-marker end)  
+  (if (< end start)
+      (psetf start end
+             end start))
+  (let* ((buf (get-buffer buffer)))
+    (when (or (< start (buffer-min buf))
+              (> end (buffer-max buf)))
+      (signal 'args-out-of-range))
+    (insert (make-buffer-string start end t buf))))
 
 (defun preceding-char ()
   "Return the character preceding point.
@@ -589,8 +595,35 @@ A multibyte character is handled correctly."
 (defun compare-buffer-substrings ()
   (error "Unimplemented"))
 
-(defun subst-char-in-region ()
-  (error "Unimplemented"))
+(defun subst-char-in-region (start end fromchar tochar &optional noundo)
+  "From START to END, replace FROMCHAR with TOCHAR each time it occurs.
+If optional arg NOUNDO is non-nil, don't record this change for undo
+and don't mark the buffer as really changed.
+Both characters must have the same length of multi-byte form."
+  (declare (ignore noundo))
+  (check-number-coerce-marker start)
+  (check-number-coerce-marker end)
+  (check-type fromchar character)
+  (check-type tochar character)
+  (multiple-value-setq (start end) (validate-region start end))
+
+  ;; FIXME: handle noundo
+  (let* ((buf (current-buffer))
+         (start-aref (buffer-char-to-aref buf start))
+         (end-aref (buffer-char-to-aref buf end)))
+    (if (or (< (gap-end buf)
+               start-aref)
+            (> (buffer-gap-start buf)
+               end-aref))
+        (nsubstitute tochar fromchar (buffer-data buf)
+                     :start start-aref
+                     :end end-aref)
+        (progn
+          (gap-move-to buf start-aref)
+          (nsubstitute tochar fromchar (buffer-data buf)
+                       :start (buffer-char-to-aref buf start)
+                       :end (buffer-char-to-aref buf end))))
+    nil))
 
 (defun translate-region-internal ()
   (error "Unimplemented"))
@@ -604,8 +637,39 @@ A multibyte character is handled correctly."
 (defun save-restriction ()
   (error "Unimplemented"))
 
-(defun transpose-regions ()
-  (error "Unimplemented"))
+(defun transpose-regions (startr1 endr1 startr2 endr2 &optional leave_markers)
+  "Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
+The regions may not be overlapping, because the size of the buffer is
+never changed in a transposition.
+
+Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
+any markers that happen to be located in the regions.
+
+Transposing beyond buffer boundaries is an error."
+  (check-number-coerce-marker startr1)
+  (check-number-coerce-marker endr1)
+  (check-number-coerce-marker startr2)
+  (check-number-coerce-marker endr2)
+  (multiple-value-setq (startr1 endr1) (validate-region startr1 endr1))
+  (multiple-value-setq (startr2 endr2) (validate-region startr2 endr2))
+  (when (< startr2 startr1)
+    (psetf startr1 startr2
+           endr1 endr2
+           startr2 startr1
+           endr2 endr1))
+  ;; no overlapping
+  (assert (<= endr1 startr2))
+  ;; FIXME: The emacs version looks optimized for a bunch of
+  ;; cases. But we're gonna cheap out
+  (let ((r1 (buffer-substring startr1 endr1))
+        (r2 (buffer-substring startr2 endr2)))
+    ;; do the 2nd one first so the positions remain valid.
+    (delete-region startr2 endr2)
+    (set-point startr2)
+    (insert r1)
+    (delete-region startr1 endr1)
+    (set-point startr1)
+    (insert r2)))
 
 (defun goto-char (position &aux (buffer (current-buffer)))
   "Set point to POSITION, a number."
@@ -628,4 +692,14 @@ A multibyte character is handled correctly."
   (check-number-coerce-marker pos)
   (buffer-char-after (current-buffer) (1- pos)))
 
+(defun substring-no-properties (string &optional (from 0) (to (length string)))
+  "Return a substring of string, without text properties.
+It starts at index from and ending before to.
+to may be nil or omitted; then the substring runs to the end of string.
+If from is nil or omitted, the substring starts at the beginning of string.
+If from or to is negative, it counts from the end.
+
+With one argument, just copy string without its properties."
+  (subseq string from to))
+
 (provide :lice-0.1/editfns)
similarity index 100%
rename from edmacro.lisp
rename to src/edmacro.lisp
diff --git a/src/elisp.lisp b/src/elisp.lisp
new file mode 100644 (file)
index 0000000..9ead271
--- /dev/null
@@ -0,0 +1,15 @@
+(cl:defpackage "ELISP"
+  (:nicknames "EL")
+  (:use "CL")
+  (:shadow cl:if)
+  (:export #:if))
+
+(in-package "ELISP")
+
+(defmacro if (test pass &rest else)
+  "Elisp version of IF."
+  `(cl:if ,test
+          ,pass
+          (progn 
+            ,@else)))
+
similarity index 100%
rename from files.lisp
rename to src/files.lisp
similarity index 100%
rename from frame.lisp
rename to src/frame.lisp
similarity index 85%
rename from global.lisp
rename to src/global.lisp
index 804ef73..3710141 100644 (file)
@@ -253,4 +253,48 @@ not compute it, store the result, and return it."
            (cdr ,match)
            (memoize-store ,mem-var ,thing ,compute)))))
 
+(defun % (number divisor)
+  "same as mod."
+  (mod number divisor))
+
+(defun add-to-list (list-var element &optional append)
+  "Add ELEMENT to the value of LIST-VAR if it isn't there yet.
+The test for presence of ELEMENT is done with `equal'.
+If ELEMENT is added, it is added at the beginning of the list,
+unless the optional argument APPEND is non-nil, in which case
+ELEMENT is added at the end.
+
+The return value is the new value of LIST-VAR.
+
+If you want to use `add-to-list' on a variable that is not defined
+until a certain package is loaded, you should put the call to `add-to-list'
+into a hook function that will be run only after loading the package.
+`eval-after-load' provides one way to do this.  In some cases
+other hooks, such as major mode hooks, can do the job."
+  (if (member element (symbol-value list-var))
+      (symbol-value list-var)
+    (set list-var
+        (if append
+            (append (symbol-value list-var) (list element))
+          (cons element (symbol-value list-var))))))
+
+(defmacro defsubst (name lambda-list &body body)
+  "Define an inline function.  The syntax is just like that of `defun'."
+  `(progn
+     (declaim (inline ,name))
+     (defun ,name ,lambda-list
+       ,@body)))
+
+(defun setcar (cell newcar)
+  "Set the car of cell to be newcar.  Returns newcar."
+  (setf (car cell) newcar))
+
+(depricate aset (setf aref))
+(defun aset (array idx newelt)
+  "Store into the element of ARRAY at index IDX the value NEWELT.
+Return NEWELT.  ARRAY may be a vector, a string, a char-table or a
+bool-vector.  IDX starts at 0."
+  (setf (aref array idx) newelt))
+
+
 (provide :lice-0.1/global)
similarity index 100%
rename from help.lisp
rename to src/help.lisp
similarity index 86%
rename from indent.lisp
rename to src/indent.lisp
index 6917471..5e16867 100644 (file)
@@ -257,8 +257,28 @@ This is consistent with other cursor motion functions
 and makes it possible to use `vertical-motion' in any buffer,
 whether or not it is currently displayed in some window."
   (declare (ignore lines window))
-  (error "unimplemented")
-  )
+  ;; FIXME: its cheap but it works, for now. It all assumes there
+  ;; aren't pictures or variable width fonts, etc.
+  (let* ((total lines)
+         (old-pt (pt))
+         (win (selected-window))
+         (width (window-width win nil))
+         (buf (current-buffer)))
+    ;; go to the beginning of the line
+    (decf old-pt (mod (current-column) width))
+    (while (and (< old-pt (zv))
+                (> lines 0))
+      (setf old-pt (1+ (buffer-scan-newline buf old-pt (+ old-pt width) 1)))
+      (decf lines))
+    (while (and (> old-pt (begv))
+                (< lines 0))
+      (setf old-pt (buffer-scan-newline buf old-pt (- old-pt width) -2))
+      ;; go past the newline except at the beginning of the buffer
+      (unless (= old-pt (begv))
+        (incf old-pt))
+      (incf lines))
+    (set-point (max (begv) (min (zv) old-pt)))
+    (- total lines)))
 
 (defun indent-line-to (column)
   "Indent current line to COLUMN.
@@ -316,3 +336,27 @@ interactively or with optional argument FORCE, it will be fixed."
 (defun indent-to-left-margin ()
   "Indent current line to the column given by `current-left-margin'."
   (indent-line-to (current-left-margin)))
+
+(defcommand beginning-of-line-text ((&optional n)
+                                    :prefix)
+  "Move to the beginning of the text on this line.
+With optional argument, move forward N-1 lines first.
+From the beginning of the line, moves past the left-margin indentation, the
+fill-prefix, and any indentation used for centering or right-justifying the
+line, but does not move past any whitespace that was explicitly inserted
+\(such as a tab used to indent the first line of a paragraph)."
+  (beginning-of-line n)
+  (skip-chars-forward " \t")
+  ;; Skip over fill-prefix.
+  (if (and *fill-prefix*
+          (not (string-equal *fill-prefix* "")))
+      (if (equal *fill-prefix*
+                (buffer-substring
+                 (point) (min (point-max) (+ (length *fill-prefix*) (point)))))
+         (forward-char (length *fill-prefix*)))
+    (if (and adaptive-fill-mode adaptive-fill-regexp
+            (looking-at adaptive-fill-regexp))
+       (goto-char (match-end 0))))
+  ;; Skip centering or flushright indentation
+  (if (memq (current-justification) '(center right))
+      (skip-chars-forward " \t")))
similarity index 100%
rename from insdel.lisp
rename to src/insdel.lisp
similarity index 100%
rename from intervals.lisp
rename to src/intervals.lisp
similarity index 83%
rename from keyboard.lisp
rename to src/keyboard.lisp
index f540aec..ae6d0ee 100644 (file)
@@ -43,27 +43,36 @@ The value is a list of KEYs."
         (*this-command* (command-name cmd))
         (*current-prefix-arg* *prefix-arg*))
     (clear-minibuffer)
-    (handler-case (funcall (command-fn cmd))
-      (quit (c)
-        (declare (ignore c))
-       ;; FIXME: debug-on-quit
+    (restart-case
+        (handler-bind
+            ((quit
+              (lambda (c)
+                (if *debug-on-quit*
+                    (signal c)
+                    (invoke-restart 'abort-command))))
+             (lice-condition
+              (lambda (c)
+                (if *debug-on-error*
+                    (signal c)
+                    (invoke-restart 'just-print-error c))))
+             (error 
+              (lambda (c)
+                (if *debug-on-error*
+                    (signal c)
+                    (invoke-restart 'just-print-error c)))))
+          (funcall (command-fn cmd)))
+      (abort-command ()
+        :report "Abort the command."
         (message "Quit"))
-      (lice-condition (c)
-        (message "~a" c))
-      ;;       (error (c)
-      ;;       ;; FIXME: lice has no debugger yet, so use the lisp's
-      ;;       ;; debugger.
-      ;;       (if *debug-on-error*
-      ;;           (error c)
-      ;;         (message "~a" c)))
-      )
+      (just-print-error (c)
+        :report "Abort and print error."
+        ;; we need a bell
+        (message "~a" c)))
     (setf *last-command* *this-command*
          ;; reset command keys, since the command is over.
          *this-command-keys* nil)
     ;; handle undo
-    (undo-boundary)
-
-))
+    (undo-boundary)))
 
 ;;; events
 
@@ -126,9 +135,10 @@ events that invoked the current command."
 (defconstant +key-tab+ 0407)
 (defconstant +key-escape+ 27)
 
-(defun wait-for-event ()
+(defun wait-for-event (&optional time)
   ;; don't let the user C-g when reading for input
-  (let ((*waiting-for-input* t))
+  (let ((*waiting-for-input* t)
+        (now (get-internal-real-time)))
     (loop
        for event = (frame-read-event (selected-frame))
        for procs = (poll-processes) do
@@ -152,7 +162,11 @@ events that invoked the current command."
               ;; but i don't know how to do that. So just sleep for a tiny
               ;; bit to pass control over to the operating system and then
               ;; check again.
-              (sleep 0.01))))))
+              (sleep 0.01)))
+       ;; let the loop run once
+       until (and time (>= (/ (- (get-internal-real-time) now)
+                              internal-time-units-per-second)
+                           time)))))
 
 
 (defun top-level-next-event ()
similarity index 100%
rename from keymap.lisp
rename to src/keymap.lisp
diff --git a/src/lice.asd b/src/lice.asd
new file mode 100644 (file)
index 0000000..4399cb9
--- /dev/null
@@ -0,0 +1,63 @@
+;; -*- lisp -*-
+
+(defpackage :lice-system (:use :cl :asdf))
+(in-package :lice-system)
+
+(load "package.lisp")
+
+(defsystem :lice
+    :depends-on (#-clisp cl-ncurses cl-ppcre #+sbcl sb-posix)
+    :components ((:file "wrappers")
+                 (:file "elisp")
+                 (:file "global")
+                 (:file "custom")
+                 (:file "commands")
+                 (:file "data-types")
+                 (:file "charset")
+                 (:file "keymap" :depends-on ("global"))
+                 (:file "casefiddle")
+                 (:file "subprocesses" :depends-on ("wrappers" "commands"))
+                 (:file "buffer-local" :depends-on ("data-types"))
+                 (:file "buffer" :depends-on ("data-types" "buffer-local" "commands" "wrappers" "global"))
+                 (:file "intervals" :depends-on ("data-types"))
+                 (:file "textprop" :depends-on ("intervals" "global"))
+                 (:file "search" :depends-on ("buffer"))
+                 (:file "frame" :depends-on ("data-types"))
+                 (:file "window" :depends-on ("buffer" "search" "commands" "frame" "data-types"))
+                 (:file "render" :depends-on ("frame" "window"))
+                 (:file "wm" :depends-on ("data-types" "window" "frame"))
+
+                 ;; from this point on there are warnings because of two-way dependencies
+                 (:file "insdel" :depends-on ("intervals" #|"undo"|# "buffer"))
+                 (:file "cmds" :depends-on ("keymap" "insdel"))
+                 (:file "editfns" :depends-on ("buffer" "insdel" "textprop" "cmds"))
+                 (:file "undo" :depends-on ("commands" "window"))
+                 (:file "syntax" :depends-on ("buffer"))
+                 (:file "major-mode" :depends-on ("keymap" "syntax"))
+                 (:file "keyboard" :depends-on ("commands" "keymap" "subprocesses" "render"))
+                 (:file "debugger" :depends-on ("commands" "major-mode"))
+                 (:file "recursive-edit" :depends-on ("keyboard" "render" "debugger"))
+                 (:file "minibuffer" :depends-on ("buffer" "window" "recursive-edit" "wm"))
+                 (:file "files" :depends-on ("buffer" "buffer-local" "commands" "custom"))
+                 (:file "help" :depends-on ("buffer" "commands"))
+                 (:file "debug" :depends-on ("buffer" "commands"))
+                 #+sbcl (:file "tty-render" :depends-on ("buffer" "window" "frame" "render"))
+                 #+clisp (:file "clisp-render" :depends-on ("buffer" "window" "frame" "render"))
+                 (:file "main" :depends-on ("buffer" "major-mode" "elisp" #+sbcl "tty-render" #+clisp "clisp-render"))
+                 (:file "indent" :depends-on (#|"subr"|#))
+
+                 (:module lisp
+                          :components ((:file "subr")
+                                       (:file "simple" :depends-on ("subr" #|"textmodes/fill"|#))
+                                       (:file "lisp-mode" :depends-on (#|"indent"|# "simple"))
+                                       (:file "lisp-indent" :depends-on ("lisp-mode" #|"indent"|# "simple"))
+                                       (:file "paragraphs" :depends-on ("simple"))))
+
+                 (:module textmodes
+                          :components (;; (:file "fill" :depends-on ()) ; this one is too advanced for now
+                                       (:file "text-mode" :depends-on ())))
+
+                 (:module play
+                          :components ((:file "dissociate" :depends-on nil)
+                                       (:file "hanoi")
+                                       (:file "doctor" :depends-on (#|"simple" "paragraphs" text-mode"|#))))))
similarity index 100%
rename from lisp-indent.lisp
rename to src/lisp/lisp-indent.lisp
similarity index 100%
rename from lisp-mode.lisp
rename to src/lisp/lisp-mode.lisp
similarity index 100%
rename from paragraphs.lisp
rename to src/lisp/paragraphs.lisp
similarity index 94%
rename from simple.lisp
rename to src/lisp/simple.lisp
index 158a8f0..f565ebb 100644 (file)
@@ -488,10 +488,10 @@ to t."
                                 (t (format nil "~a M-x " prefix)))))
          (cmd (lookup-command name)))
     (if cmd
-       (progn
+       (let ((*prefix-arg* prefix))
          (dispatch-command name)
           (setf *this-command* (command-name cmd)))
-      (message "No Match"))))
+        (message "No Match"))))
 
 (defcommand switch-to-buffer ((buffer &optional norecord)
                              (:buffer "Switch To Buffer: " (buffer-name (other-buffer (current-buffer)))))
@@ -584,14 +584,14 @@ In Transient Mark mode, this does not activate the mark."
                        :raw-prefix)
   (let ((win (selected-window)))
     (window-scroll-up win (max 1 (or (and arg (prefix-numeric-value arg))
-                                     (- (window-height win)
+                                     (- (window-height win nil)
                                         *next-screen-context-lines*))))))
 
 (defcommand scroll-down ((&optional arg)
                          :raw-prefix)
   (let ((win (selected-window)))
     (window-scroll-down win (max 1 (or (and arg (prefix-numeric-value arg))
-                                       (- (window-height win)
+                                       (- (window-height win nil)
                                           *next-screen-context-lines*))))))
 
 (defcommand end-of-buffer ()
@@ -998,6 +998,7 @@ With argument 0, interchanges line point is in with line mark is in."
      (goto-char (car pos1))
      (insert word2)))
 
+\f
 ;;; 
 
 (defcustom-buffer-local *fill-prefix* nil
@@ -1020,6 +1021,104 @@ Other major modes are defined by comparison with this one.")
   ;; FIXME: implement
   )
 
+(define-buffer-local comment-line-break-function 'comment-indent-new-line
+  "*Mode-specific function which line breaks and continues a comment.
+
+This function is only called during auto-filling of a comment section.
+The function should take a single optional argument, which is a flag
+indicating whether it should use soft newlines.")
+
+(defun do-auto-fill ()
+  "This function is used as the auto-fill-function of a buffer
+when Auto-Fill mode is enabled.
+It returns t if it really did any work.
+\(Actually some major modes use a different auto-fill function,
+but this one is the default one.)"
+  (let (fc justify give-up
+          (*fill-prefix* *fill-prefix*))
+    (el:if (or (not (setq justify (current-justification)))
+           (null (setq fc (current-fill-column)))
+           (and (eq justify 'left)
+                (<= (current-column) fc))
+           (and auto-fill-inhibit-regexp
+                (save-excursion (beginning-of-line)
+                                (looking-at auto-fill-inhibit-regexp))))
+       nil ;; Auto-filling not required
+      (el:if (memq justify '(full center right))
+         (save-excursion (unjustify-current-line)))
+
+      ;; Choose a *fill-prefix* automatically.
+      (when (and adaptive-fill-mode
+                (or (null *fill-prefix*) (string= *fill-prefix* "")))
+       (let ((prefix
+              (fill-context-prefix
+               (save-excursion (backward-paragraph 1) (point))
+               (save-excursion (forward-paragraph 1) (point)))))
+         (and prefix (not (equal prefix ""))
+              ;; Use auto-indentation rather than a guessed empty prefix.
+              (not (and fill-indent-according-to-mode
+                        (string-match "\\`[ \t]*\\'" prefix)))
+              (setq *fill-prefix* prefix))))
+
+      (while (and (not give-up) (> (current-column) fc))
+       ;; Determine where to split the line.
+       (let* (after-prefix
+              (fill-point
+               (save-excursion
+                 (beginning-of-line)
+                 (setq after-prefix (point))
+                 (and *fill-prefix*
+                      (looking-at (regexp-quote *fill-prefix*))
+                      (setq after-prefix (match-end 0)))
+                 (move-to-column (1+ fc))
+                 (fill-move-to-break-point after-prefix)
+                 (point))))
+
+         ;; See whether the place we found is any good.
+         (el:if (save-excursion
+               (goto-char fill-point)
+               (or (bolp)
+                   ;; There is no use breaking at end of line.
+                   (save-excursion (skip-chars-forward " ") (eolp))
+                   ;; It is futile to split at the end of the prefix
+                   ;; since we would just insert the prefix again.
+                   (and after-prefix (<= (point) after-prefix))
+                   ;; Don't split right after a comment starter
+                   ;; since we would just make another comment starter.
+                   (and comment-start-skip
+                        (let ((limit (point)))
+                          (beginning-of-line)
+                          (and (re-search-forward comment-start-skip
+                                                  limit t)
+                               (eq (point) limit))))))
+             ;; No good place to break => stop trying.
+             (setq give-up t)
+           ;; Ok, we have a useful place to break the line.  Do it.
+           (let ((prev-column (current-column)))
+             ;; If point is at the fill-point, do not `save-excursion'.
+             ;; Otherwise, if a comment prefix or *fill-prefix* is inserted,
+             ;; point will end up before it rather than after it.
+             (el:if (save-excursion
+                   (skip-chars-backward " \t")
+                   (= (point) fill-point))
+                 (funcall comment-line-break-function t)
+               (save-excursion
+                 (goto-char fill-point)
+                 (funcall comment-line-break-function t)))
+             ;; Now do justification, if required
+             (el:if (not (eq justify 'left))
+                 (save-excursion
+                   (end-of-line 0)
+                   (justify-current-line justify nil t)))
+             ;; If making the new line didn't reduce the hpos of
+             ;; the end of the line, then give up now;
+             ;; trying again will not help.
+             (el:if (>= (current-column) prev-column)
+                 (setq give-up t))))))
+      ;; Justify last line.
+      (justify-current-line justify t t)
+      t)))
+
 \f
 ;; FIXME: put this info in the following condition
 ;; (put 'mark-inactive 'error-conditions '(mark-inactive error))
@@ -1694,4 +1793,19 @@ and the function returns nil.  Field boundaries are not noticed if
                             (goto-char (point-min)))
                           p2)))))))
 
+(defvar line-number-mode nil
+  )
+
+(defvar column-number-mode nil
+  )
+
+(defun line-number-mode (&optional arg)
+  ""
+  (warn "Unimplemented"))
+
+(defun column-number-mode (&optional arg)
+  ""
+  (warn "Unimplemented"))
+
+
 (provide :lice-0.1/simple)
similarity index 81%
rename from subr.lisp
rename to src/lisp/subr.lisp
index 11cd8a7..04a099a 100644 (file)
--- a/subr.lisp
@@ -187,8 +187,53 @@ Optional arg nodisp non-nil means don't redisplay, just wait for input.
 Redisplay is preempted as always if input arrives, and does not happen
 if input is available before it starts.
 Value is t if waited the full time with no input arriving."
-  (declare (ignore seconds nodisp))
-  ;; FIXME: actually sleep
-  (frame-render (selected-frame)))
+  (unless nodisp
+    (frame-render (selected-frame)))
+  ;; FIXME: poll for input
+  (sleep seconds)
+  t
+;;   (let ((event (wait-for-event seconds)))
+;;     (if event
+;;         (progn
+;;           (push event *unread-command-events*)
+;;           nil)
+;;         t))
+  )
+
+\f
+;;; Matching and match data
+(defun match-string (num &optional string)
+  "Return string of text matched by last search.
+NUM specifies which parenthesized expression in the last regexp.
+ Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
+Zero means the entire text matched by the whole regexp or whole string.
+STRING should be given if the last search was by `string-match' on STRING."
+  (if (match-beginning num)
+      (if string
+         (substring string (match-beginning num) (match-end num))
+       (buffer-substring (match-beginning num) (match-end num)))))
+
+(defun match-string-no-properties (num &optional string)
+  "Return string of text matched by last search, without text properties.
+NUM specifies which parenthesized expression in the last regexp.
+ Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
+Zero means the entire text matched by the whole regexp or whole string.
+STRING should be given if the last search was by `string-match' on STRING."
+  (if (match-beginning num)
+      (if string
+         (substring-no-properties string (match-beginning num)
+                                  (match-end num))
+       (buffer-substring-no-properties (match-beginning num)
+                                       (match-end num)))))
+
+
+(defun force-mode-line-update (&optional all)
+  "Force redisplay of the current buffer's mode line and header line.
+With optional non-nil ALL, force redisplay of all mode lines and
+header lines.  This function also forces recomputation of the
+menu bar menus and the frame title."
+;;   (if all (save-excursion (set-buffer (other-buffer))))
+;;   (set-buffer-modified-p (buffer-modified-p))
+  )
 
 (provide :lice-0.1/subr)
similarity index 100%
rename from load.lisp
rename to src/load.lisp
similarity index 100%
rename from main.lisp
rename to src/main.lisp
similarity index 100%
rename from major-mode.lisp
rename to src/major-mode.lisp
similarity index 100%
rename from make-image.lisp
rename to src/make-image.lisp
similarity index 100%
rename from mcl-load.lisp
rename to src/mcl-load.lisp
similarity index 96%
rename from mcl-render.lisp
rename to src/mcl-render.lisp
index bf89177..1a68957 100644 (file)
@@ -62,7 +62,7 @@ hardware.")
           (type fixnum y start))
 ;;   (let ((display (frame-2d-double-buffer frame))
 ;;     (linear (frame-double-buffer frame)))
-    (clear-line-between window y start (1- (window-width window)) frame)
+    (clear-line-between window y start (1- (window-width window nil)) frame)
     ;; draw the seperator
     (when (window-seperator window)
       (putch #\| (+ (window-x window) (1- (window-width window t))) y window frame)))
@@ -102,12 +102,12 @@ hardware.")
     ;; Special case: when the buffer is empty
     (if (= (buffer-size (window-buffer w)) 0)
        (progn 
-         (dotimes (y (window-height w))
+         (dotimes (y (window-height w nil))
            (clear-to-eol y 0 w frame))
          (setf cursor-x 0
                cursor-y 0))
       (let ((end (loop named row
-                      for y below (window-height w)
+                      for y below (window-height w nil)
                       for line from (window-top-line w) below cache-size
                       ;; return the last line, so we can erase the rest
                       finally (return-from row y)
@@ -120,7 +120,7 @@ hardware.")
                            ;; setup the display properties.
                            (turn-on-attributes (window-buffer w) bp)
                            (loop named col
-                               for x below (window-width w) do
+                               for x below (window-width w nil) do
                                (progn
                                  ;; Skip the gap
                                  (when (= p (buffer-gap-start buf))
@@ -147,18 +147,18 @@ hardware.")
                                    (incf p)
                                    (incf bp))))))))
        ;; Check if the bottom of the window needs to be erased.
-       (when (< end (1- (window-height w)))
-         (loop for i from end below (window-height w) do
+       (when (< end (1- (window-height w nil)))
+         (loop for i from end below (window-height w nil) do
                (clear-to-eol i 0 w frame)))))
     ;; Update the mode-line if it exists. FIXME: Not the right place
     ;; to update the mode-line.
     (when (buffer-mode-line (window-buffer w))
       (update-mode-line (window-buffer w))
-      (putstr (truncate-mode-line (window-buffer w) (window-width w))
+      (putstr (truncate-mode-line (window-buffer w) (window-width w nil))
              0 (window-height w nil) w frame)
       ;; don't forget the seperator on the modeline line
       (when (window-seperator w)
-       (putch #\| (+ (window-x w) (window-width w)) (window-height w) w frame)))
+       (putch #\| (+ (window-x w) (window-width w nil)) (window-height w nil) w frame)))
     (reset-line-state w)
     ;; Set the cursor at the right spot
     (values cursor-x cursor-y)))
similarity index 100%
rename from minibuffer.lisp
rename to src/minibuffer.lisp
similarity index 95%
rename from movitz-render.lisp
rename to src/movitz-render.lisp
index 3c25fac..9e598e3 100644 (file)
@@ -61,7 +61,7 @@ hardware.")
   (let (;; (display (frame-2d-double-buffer frame))
        ;; (linear (frame-double-buffer frame))
        )
-    (clear-line-between window y start (1- (window-width window)) frame)
+    (clear-line-between window y start (1- (window-width window nil)) frame)
     ;; draw the seperator
     (when (window-seperator window)
       (putch #\| (+ (window-x window) (1- (window-width window t))) y window frame))))
@@ -102,12 +102,12 @@ the text properties present."
     ;; Special case: when the buffer is empty
     (if (= (buffer-size (window-buffer w)) 0)
        (progn 
-         (dotimes (y (window-height w))
+         (dotimes (y (window-height w nil))
            (clear-to-eol y 0 w frame))
          (setf cursor-x 0
                cursor-y 0))
       (let ((end (loop named row
-                      for y below (window-height w)
+                      for y below (window-height w nil)
                       for line from (window-top-line w) below cache-size
                       ;; return the last line, so we can erase the rest
                       finally (return-from row y)
@@ -120,7 +120,7 @@ the text properties present."
                            ;; setup the display properties.
                            (turn-on-attributes (window-buffer w) bp)
                            (loop named col
-                               for x below (window-width w) do
+                               for x below (window-width w nil) do
                                (progn
                                  ;; Skip the gap
                                  (when (= p (buffer-gap-start buf))
@@ -149,8 +149,8 @@ the text properties present."
                                    (incf p)
                                    (incf bp))))))))
        ;; Check if the bottom of the window needs to be erased.
-       (when (< end (1- (window-height w)))
-         (loop for i from end below (window-height w) do
+       (when (< end (1- (window-height w nil)))
+         (loop for i from end below (window-height w nil) do
                (clear-to-eol i 0 w frame)))))
     ;; rxvt draws black on black if i don't turn on a color
     (setf *current-attribute* 7)
@@ -160,13 +160,13 @@ the text properties present."
       (update-mode-line (window-buffer w))
       ;;(cl-ncurses::attron cl-ncurses::A_REVERSE)
       (setf *current-attribute* 18)
-      (putstr (truncate-mode-line (window-buffer w) (window-width w))
+      (putstr (truncate-mode-line (window-buffer w) (window-width w nil))
              0 (window-height w nil) w frame)
       (setf *current-attribute* 7)
       ;;(cl-ncurses::attroff cl-ncurses::A_REVERSE)
       ;; don't forget the seperator on the modeline line
       (when (window-seperator w)
-       (putch #\| (+ (window-x w) (window-width w)) (window-height w) w frame)))
+       (putch #\| (+ (window-x w) (window-width w nil)) (window-height w nil) w frame)))
     (reset-line-state w)
     ;; Set the cursor at the right spot
     (values cursor-x cursor-y)))
similarity index 100%
rename from package.lisp
rename to src/package.lisp
diff --git a/src/play/dissociate.lisp b/src/play/dissociate.lisp
new file mode 100644 (file)
index 0000000..bbdbb7a
--- /dev/null
@@ -0,0 +1,105 @@
+;;; dissociate.lisp --- scramble text amusingly for Emacs
+
+;; Copyright (C) 1985, 2002, 2003, 2004, 2005,
+;;   2006 Free Software Foundation, Inc.
+
+;; Maintainer: FSF
+;; Keywords: games
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Commentary:
+
+;; The single entry point, `dissociated-press', applies a travesty
+;; generator to the current buffer.  The results can be quite amusing.
+
+;;; Code:
+
+(in-package "LICE")
+
+;;;###autoload
+(defcommand dissociated-press ((&optional arg)
+                               :raw-prefix)
+  "Dissociate the text of the current buffer.
+Output goes in buffer named *Dissociation*,
+which is redisplayed each time text is added to it.
+Every so often the user must say whether to continue.
+If ARG is positive, require ARG chars of continuity.
+If ARG is negative, require -ARG words of continuity.
+Default is 2."
+  (setq arg (if arg (prefix-numeric-value arg) 2))
+  (let* ((inbuf (current-buffer))
+        (outbuf (get-buffer-create "*Dissociation*"))
+        (move-function (if (> arg 0) 'forward-char 'forward-word))
+        (move-amount (if (> arg 0) arg (- arg)))
+        (search-function (if (> arg 0) 'search-forward 'word-search-forward))
+        (last-query-point 0))
+    (if (= (point-max) (point-min))
+       (error "The buffer contains no text to start from"))
+    (switch-to-buffer outbuf)
+    (erase-buffer)
+    (while
+      (save-excursion
+       (goto-char last-query-point)
+       (vertical-motion (- (window-height) 4))
+       (or (= (point) (point-max))
+           (and (progn (goto-char (point-max))
+                       (y-or-n-p "Continue dissociation? "))
+                (progn
+                  (message "")
+                  (recenter 1)
+                  (setq last-query-point (point-max))
+                  t))))
+      (let (start end)
+       (save-excursion
+        (set-buffer inbuf)
+        (setq start (point))
+        (if (eq move-function 'forward-char)
+            (progn
+              (setq end (+ start (+ move-amount (random 16))))
+              (if (> end (point-max))
+                  (setq end (+ 1 move-amount (random 16))))
+              (goto-char end))
+          (funcall move-function
+                   (+ move-amount (random 16))))
+        (setq end (point)))
+       (let ((opoint (point)))
+         (insert-buffer-substring inbuf start end)
+         (save-excursion
+          (goto-char opoint)
+          (end-of-line)
+          (and (> (current-column) *fill-column*)
+               (do-auto-fill)))))
+      (save-excursion
+       (set-buffer inbuf)
+       (if (eobp)
+          (goto-char (point-min))
+        (let ((overlap
+               (buffer-substring (prog1 (point)
+                                        (funcall move-function
+                                                 (- move-amount)))
+                                 (point))))
+          (goto-char (1+ (random (1- (point-max)))))
+          (or (funcall search-function overlap :error nil)
+              (let ((opoint (point)))
+                (goto-char 1)
+                (funcall search-function overlap :bound opoint :error nil))))))
+      (sit-for 0))))
+
+(provide 'dissociate)
+
+;;; arch-tag: 90d197d1-409b-45c5-a0b5-fbfb2e06334f
+;;; dissociate.el ends here
similarity index 100%
rename from doctor.lisp
rename to src/play/doctor.lisp
diff --git a/src/play/hanoi.lisp b/src/play/hanoi.lisp
new file mode 100644 (file)
index 0000000..b1de6b2
--- /dev/null
@@ -0,0 +1,448 @@
+;;; hanoi.el --- towers of hanoi in Emacs
+
+;; Author: Damon Anton Permezel
+;; Maintainer: FSF
+;; Keywords: games
+
+; Author (a) 1985, Damon Anton Permezel
+; This is in the public domain
+; since he distributed it without copyright notice in 1985.
+;; This file is part of GNU Emacs.
+;
+; Support for horizontal poles, large numbers of rings, real-time,
+; faces, defcustom, and Towers of Unix added in 1999 by Alakazam
+; Petrofsky <Alakazam@Petrofsky.Berkeley.CA.US>.
+
+;;; Commentary:
+
+;; Solves the Towers of Hanoi puzzle while-U-wait.
+;;
+;; The puzzle: Start with N rings, decreasing in sizes from bottom to
+;; top, stacked around a post.  There are two other posts.  Your mission,
+;; should you choose to accept it, is to shift the pile, stacked in its
+;; original order, to another post.
+;;
+;; The challenge is to do it in the fewest possible moves.  Each move
+;; shifts one ring to a different post.  But there's a rule; you can
+;; only stack a ring on top of a larger one.
+;;
+;; The simplest nontrivial version of this puzzle is N = 3.  Solution
+;; time rises as 2**N, and programs to solve it have long been considered
+;; classic introductory exercises in the use of recursion.
+;;
+;; The puzzle is called `Towers of Hanoi' because an early popular
+;; presentation wove a fanciful legend around it.  According to this
+;; myth (uttered long before the Vietnam War), there is a Buddhist
+;; monastery at Hanoi which contains a large room with three time-worn
+;; posts in it surrounded by 21 golden discs.  Monks, acting out the
+;; command of an ancient prophecy, have been moving these disks, in
+;; accordance with the rules of the puzzle, once every day since the
+;; monastery was founded over a thousand years ago.  They are said to
+;; believe that when the last move of the puzzle is completed, the
+;; world will end in a clap of thunder.  Fortunately, they are nowhere
+;; even close to being done...
+;;
+;; 1999 addition: The `Towers of Unix' command (hanoi-unix) stems from
+;; the never-disproven legend of a Eunuch monastery at Princeton that
+;; contains a large air-conditioned room with three time-worn posts in
+;; it surrounded by 32 silicon discs.  Nimble monks, acting out the
+;; command of an ancient prophecy, have been moving these disks, in
+;; accordance with the rules of the puzzle, once every second since
+;; the monastery was founded almost a billion seconds ago.  They are
+;; said to believe that when the last move of the puzzle is completed,
+;; the world will reboot in a clap of thunder.  Actually, because the
+;; bottom disc is blocked by the "Do not feed the monks" sign, it is
+;; believed the End will come at the time that disc is to be moved...
+
+;;; Code:
+
+(in-package "LICE")
+
+;; dynamic bondage:
+(defvar baseward-step)
+(defvar fly-step)
+(defvar fly-row-start)
+(defvar pole-width)
+(defvar pole-char)
+(defvar line-offset)
+
+(defgroup hanoi nil
+  "The Towers of Hanoi."
+  :group 'games)
+
+(defcustom hanoi-horizontal-flag nil
+  "*If non-nil, hanoi poles are oriented horizontally."
+  :group 'hanoi :type 'boolean)
+
+(defcustom hanoi-move-period 1.0
+  "*Time, in seconds, for each pole-to-pole move of a ring.
+If nil, move rings as fast as possible while displaying all
+intermediate positions."
+  :group 'hanoi :type '(restricted-sexp :match-alternatives (numberp 'nil)))
+
+(defcustom hanoi-use-faces nil
+  "*If nil, all hanoi-*-face variables are ignored."
+  :group 'hanoi :type 'boolean)
+
+(defcustom hanoi-pole-face 'highlight
+  "*Face for poles.  Ignored if hanoi-use-faces is nil."
+  :group 'hanoi :type 'face)
+
+(defcustom hanoi-base-face 'highlight
+  "*Face for base.  Ignored if hanoi-use-faces is nil."
+  :group 'hanoi :type 'face)
+
+(defcustom hanoi-even-ring-face 'region
+  "*Face for even-numbered rings.  Ignored if hanoi-use-faces is nil."
+  :group 'hanoi :type 'face)
+
+(defcustom hanoi-odd-ring-face 'secondary-selection
+  "*Face for odd-numbered rings.  Ignored if hanoi-use-faces is nil."
+  :group 'hanoi :type 'face)
+
+
+;;;
+;;; hanoi - user callable Towers of Hanoi
+;;;
+;;;###autoload
+(defcommand hanoi ((nrings)
+                   :prefix)
+  "Towers of Hanoi diversion.  Use NRINGS rings."
+  (setf nrings (max 3 nrings))
+;;   (if (< nrings 0)
+;;       (error "Negative number of rings"))
+  (hanoi-internal nrings (make-list nrings :initial-element 0) (hanoi-current-time-float)))
+
+;;;###autoload
+(defcommand hanoi-unix ()
+  "Towers of Hanoi, UNIX doomsday version.
+Displays 32-ring towers that have been progressing at one move per
+second since 1970-01-01 00:00:00 GMT.
+
+Repent before ring 31 moves."
+  (let* ((start (ftruncate (hanoi-current-time-float)))
+        (bits (loop repeat 32
+                    for x = (/ start (expt 2.0 31)) then (* x 2.0)
+                    collect (truncate (mod x 2.0))))
+        (hanoi-move-period 1.0))
+    (hanoi-internal 32 bits start)))
+
+;;;###autoload
+(defcommand hanoi-unix-64 ()
+  "Like hanoi-unix, but pretend to have a 64-bit clock.
+This is, necessarily (as of emacs 20.3), a crock.  When the
+current-time interface is made s2G-compliant, hanoi.el will need
+to be updated."
+  (let* ((start (ftruncate (hanoi-current-time-float)))
+        (bits (loop repeat 64
+                    for x = (/ start (expt 2.0 63)) then (* x 2.0)
+                    collect (truncate (mod x 2.0))))
+        (hanoi-move-period 1.0))
+    (hanoi-internal 64 bits start)))
+
+(defun hanoi-internal (nrings bits start-time)
+  "Towers of Hanoi internal interface.  Use NRINGS rings.
+Start after n steps, where BITS is a big-endian list of the bits of n.
+BITS must be of length nrings.  Start at START-TIME."
+  (switch-to-buffer "*Hanoi*")
+  (buffer-disable-undo (current-buffer))
+  (unwind-protect
+      (let*
+         (;; These lines can cause emacs to crash if you ask for too
+          ;; many rings.  If you uncomment them, on most systems you
+          ;; can get 10,000+ rings.
+          ;;(max-specpdl-size (max max-specpdl-size (* nrings 15)))
+          ;;(max-lisp-eval-depth (max max-lisp-eval-depth (+ nrings 20)))
+          (vert (not hanoi-horizontal-flag))
+          (pole-width (length (format nil "~d" (max 0 (1- nrings)))))
+          (pole-char (if vert #\| #\-))
+          (base-char (if vert #\= #\|))
+          (base-len (max (+ 8 (* pole-width 3))
+                         (1- (if vert (window-width) (window-height)))))
+          (max-ring-diameter (truncate (- base-len 2) 3))
+          (pole1-coord (truncate max-ring-diameter 2))
+          (pole2-coord (truncate base-len 2))
+          (pole3-coord (- base-len (truncate (1+ max-ring-diameter) 2)))
+          (pole-coords (list pole1-coord pole2-coord pole3-coord))
+          ;; Number of lines displayed below the bottom-most rings.
+          (base-lines
+           (min 3 (max 0 (- (1- (if vert (window-height) (window-width)))
+                            (+ 2 nrings)))))
+
+          ;; These variables will be set according to hanoi-horizontal-flag:
+
+          ;; line-offset is the number of characters per line in the buffer.
+          line-offset
+          ;; fly-row-start is the buffer position of the leftmost or
+          ;; uppermost position in the fly row.
+          fly-row-start
+          ;; Adding fly-step to a buffer position moves you one step
+          ;; along the fly row in the direction from pole1 to pole2.
+          fly-step
+          ;; Adding baseward-step to a buffer position moves you one step
+          ;; toward the base.
+          baseward-step
+          )
+       (setf (buffer-read-only) nil)
+       (erase-buffer)
+       (setq truncate-lines t)
+       (el:if hanoi-horizontal-flag
+           (progn
+             (setq line-offset (+ base-lines nrings 3))
+             (setq fly-row-start (1- line-offset))
+             (setq fly-step line-offset)
+             (setq baseward-step -1)
+             (loop repeat base-len do
+                   (unless (zerop base-lines)
+                     (insert-char #\Space (1- base-lines))
+                     (insert base-char)
+                     (hanoi-put-face (1- (point)) (point) hanoi-base-face))
+                   (insert-char #\Space (+ 2 nrings))
+                   (insert #\Newline))
+             (delete-char -1)
+             (loop for coord in pole-coords do
+                   (loop for row from (- coord (truncate pole-width 2))
+                         for start = (+ (* row line-offset) base-lines 1)
+                         repeat pole-width do
+                         (subst-char-in-region start (+ start nrings 1)
+                                               #\Space pole-char)
+                         (hanoi-put-face start (+ start nrings 1)
+                                         hanoi-pole-face))))
+         ;; vertical
+         (setq line-offset (1+ base-len))
+         (setq fly-step 1)
+         (setq baseward-step line-offset)
+         (let ((extra-lines (- (1- (window-height)) (+ nrings 2) base-lines)))
+           (insert-char #\Newline (max 0 extra-lines))
+           (setq fly-row-start (point))
+           (insert-char #\Space base-len)
+           (insert #\Newline)
+           (loop repeat (1+ nrings)
+                 with pole-line =
+                 (loop with line = (make-string base-len :initial-element #\Space)
+                       for coord in pole-coords
+                       for start = (- coord (truncate pole-width 2))
+                       for end = (+ start pole-width) do
+                       (hanoi-put-face start end hanoi-pole-face line)
+                       (loop for i from start below end do
+                             (aset line i pole-char))
+                       finally (return line))
+                 do (insert pole-line #\Newline))
+           (insert-char base-char base-len)
+           (hanoi-put-face (- (point) base-len) (point) hanoi-base-face)
+           (set-window-start (selected-window)
+                             (1+ (* baseward-step
+                                    (max 0 (- extra-lines)))))))
+
+       (let
+           (;; each pole is a pair of buffer positions:
+            ;; the car is the position of the top ring currently on the pole,
+            ;;   (or the base of the pole if it is empty).
+            ;; the cdr is in the fly-row just above the pole.
+            (poles (loop for coord in pole-coords
+                         for fly-pos = (+ fly-row-start (* fly-step coord))
+                         for base = (+ fly-pos (* baseward-step (+ 2 nrings)))
+                         collect (cons base fly-pos)))
+            ;; compute the string for each ring and make the list of
+            ;; ring pairs.  Each ring pair is initially (str . diameter).
+            ;; Once placed in buffer it is changed to (center-pos . diameter).
+            (rings
+             (loop
+               ;; radii are measured from the edge of the pole out.
+               ;; So diameter = 2 * radius + pole-width.  When
+               ;; there's room, we make each ring's radius =
+               ;; pole-number + 1.  If there isn't room, we step
+               ;; evenly from the max radius down to 1.
+               with max-radius = (min nrings
+                                      (truncate (- max-ring-diameter pole-width) 2))
+               for n from (1- nrings) downto 0
+               for radius =  (1+ (truncate (* n max-radius) nrings))
+               for diameter = (+ pole-width (* 2 radius))
+               with format-str = (format nil "~~~d,'0d" pole-width)
+               for str = (concat (if vert "<" "^")
+                                 (make-string (1- radius) :initial-element (if vert #\- #\|))
+                                 (format nil format-str n)
+                                 (make-string (1- radius) :initial-element (if vert #\- #\|))
+                                 (if vert ">" "v"))
+               for face =
+                 (if (eq (logand n 1) 1) ; oddp would require cl at runtime
+                     hanoi-odd-ring-face hanoi-even-ring-face)
+               do (hanoi-put-face 0 (length str) face str)
+               collect (cons str diameter)))
+            ;; Disable display of line and column numbers, for speed.
+            (line-number-mode nil) (column-number-mode nil))
+         ;; do it!
+         (hanoi-n bits rings (car poles) (cadr poles) (caddr poles)
+                  start-time))
+       (message "Done"))
+    (setf (buffer-read-only) t)
+    (force-mode-line-update)))
+
+(defun hanoi-current-time-float ()
+  "Return values from current-time combined into a single float."
+  (+ (get-universal-time)
+     (/ (get-internal-real-time)
+        internal-time-units-per-second)))
+
+(defun hanoi-put-face (start end value &optional object)
+  "If hanoi-use-faces is non-nil, call put-text-property for face property."
+  (if hanoi-use-faces
+      (put-text-property start end 'face value object)))
+
+\f
+;;; Functions with a start-time argument (hanoi-0, hanoi-n, and
+;;; hanoi-move-ring) start working at start-time and return the ending
+;;; time.  If hanoi-move-period is nil, start-time is ignored and the
+;;; return value is junk.
+
+;;;
+;;; hanoi-0 - work horse of hanoi
+(defun hanoi-0 (rings from to work start-time)
+  (if (null rings)
+      start-time
+    (hanoi-0 (cdr rings) work to from
+            (hanoi-move-ring (car rings) from to
+                             (hanoi-0 (cdr rings) from work to start-time)))))
+
+;; start after n moves, where BITS is a big-endian list of the bits of n.
+;; BITS must be of same length as rings.
+(defun hanoi-n (bits rings from to work start-time)
+  (cond ((null rings)
+        ;; All rings have been placed in starting positions.  Update display.
+        (hanoi-sit-for 0)
+        start-time)
+       ((zerop (car bits))
+        (hanoi-insert-ring (car rings) from)
+        (hanoi-0 (cdr rings) work to from
+                 (hanoi-move-ring (car rings) from to
+                                  (hanoi-n (cdr bits) (cdr rings) from work to
+                                           start-time))))
+       (t
+        (hanoi-insert-ring (car rings) to)
+        (hanoi-n (cdr bits) (cdr rings) work to from start-time))))
+
+;; put never-before-placed RING on POLE and update their cars.
+(defun hanoi-insert-ring (ring pole)
+  (decf (car pole) baseward-step)
+  (let ((str (car ring))
+       (start (- (car pole) (* (truncate (cdr ring) 2) fly-step))))
+    (setcar ring (car pole))
+    (loop for pos upfrom start by fly-step
+             for i below (cdr ring) do
+             (subst-char-in-region pos (1+ pos) (char-after pos) (aref str i))
+             (set-text-properties pos (1+ pos) (text-properties-at i str)))
+    (hanoi-goto-char (car pole))))
+
+;; like goto-char, but if position is outside the window, then move to
+;; corresponding position in the first row displayed.
+(defun hanoi-goto-char (pos)
+  (goto-char (if (or hanoi-horizontal-flag (<= (window-start) pos))
+                pos
+              (+ (window-start) (% (- pos fly-row-start) baseward-step)))))
+
+;; do one pole-to-pole move and update the ring and pole pairs.
+(defun hanoi-move-ring (ring from to start-time)
+  (incf (car from) baseward-step)
+  (decf (car to) baseward-step)
+  (let* ;; We move flywards-steps steps up the pole to the fly row,
+       ;; then fly fly-steps steps across the fly row, then go
+       ;; baseward-steps steps down the new pole.
+       ((flyward-steps (/ (- (car ring) (cdr from)) baseward-step))
+        (fly-steps (abs (/ (- (cdr to) (cdr from)) fly-step)))
+        (directed-fly-step (/ (- (cdr to) (cdr from)) fly-steps))
+        (baseward-steps (/ (- (car to) (cdr to)) baseward-step))
+        (total-steps (+ flyward-steps fly-steps baseward-steps))
+        ;; A step is a character cell.  A tick is a time-unit.  To
+        ;; make horizontal and vertical motion appear roughly the
+        ;; same speed, we allow one tick per horizontal step and two
+        ;; ticks per vertical step.
+        (ticks-per-pole-step (if hanoi-horizontal-flag 1 2))
+        (ticks-per-fly-step (if hanoi-horizontal-flag 2 1))
+        (flyward-ticks (* ticks-per-pole-step flyward-steps))
+        (fly-ticks (* ticks-per-fly-step fly-steps))
+        (baseward-ticks (* ticks-per-pole-step baseward-steps))
+        (total-ticks (+ flyward-ticks fly-ticks baseward-ticks))
+        (tick-to-pos
+         ;; Return the buffer position of the ring after TICK ticks.
+         (lambda (tick)
+           (cond
+            ((<= tick flyward-ticks)
+             (+ (cdr from)
+                (* baseward-step
+                   (- flyward-steps (truncate tick ticks-per-pole-step)))))
+            ((<= tick (+ flyward-ticks fly-ticks))
+             (+ (cdr from)
+                (* directed-fly-step
+                   (truncate (- tick flyward-ticks) ticks-per-fly-step))))
+            (t
+             (+ (cdr to)
+                (* baseward-step
+                   (truncate (- tick flyward-ticks fly-ticks)
+                      ticks-per-pole-step))))))))
+    (declare (ignore total-steps))
+    (if hanoi-move-period
+       (loop for elapsed = (- (hanoi-current-time-float) start-time)
+             while (< elapsed hanoi-move-period)
+             with tick-period = (/ (float hanoi-move-period) total-ticks)
+             for tick = (ceiling (/ elapsed tick-period)) do
+             (hanoi-ring-to-pos ring (funcall tick-to-pos tick))
+             (hanoi-sit-for (- (* tick tick-period) elapsed)))
+      (loop for tick from 1 to total-ticks by 2 do
+           (hanoi-ring-to-pos ring (funcall tick-to-pos tick))
+           (hanoi-sit-for 0)))
+    ;; Always make last move to keep pole and ring data consistent
+    (hanoi-ring-to-pos ring (car to))
+    (if hanoi-move-period (+ start-time hanoi-move-period))))
+
+;; update display and pause, quitting with a pithy comment if the user
+;; hits a key.
+(defun hanoi-sit-for (seconds)
+  (unless (sit-for seconds)
+    (signal 'quit '("I can tell you've had enough"))))
+
+;; move ring to a given buffer position and update ring's car.
+(defun hanoi-ring-to-pos (ring pos)
+  (unless (= (car ring) pos)
+    (let* ((start (- (car ring) (* (truncate (cdr ring) 2) fly-step)))
+          (new-start (- pos (- (car ring) start))))
+      (if hanoi-horizontal-flag
+         (loop for i below (cdr ring)
+               for j = (if (< new-start start) i (- (cdr ring) i 1))
+               for old-pos = (+ start (* j fly-step))
+               for new-pos = (+ new-start (* j fly-step)) do
+               (transpose-regions old-pos (1+ old-pos) new-pos (1+ new-pos)))
+       (let ((end (+ start (cdr ring)))
+             (new-end (+ new-start (cdr ring))))
+         (if (< (abs (- new-start start)) (- end start))
+             ;; Overlap.  Adjust bounds
+             (if (< start new-start)
+                 (setq new-start end)
+               (setq new-end start)))
+         (transpose-regions start end new-start new-end t))))
+    ;; If moved on or off a pole, redraw pole chars.
+    (unless (eq (hanoi-pos-on-tower-p (car ring)) (hanoi-pos-on-tower-p pos))
+      (let* ((pole-start (- (car ring) (* fly-step (truncate pole-width 2))))
+            (pole-end (+ pole-start (* fly-step pole-width)))
+            (on-pole (hanoi-pos-on-tower-p (car ring)))
+            (new-char (if on-pole pole-char #\Space))
+            (curr-char (if on-pole #\Space pole-char))
+            (face (if on-pole hanoi-pole-face nil)))
+       (el:if hanoi-horizontal-flag
+           (loop for pos from pole-start below pole-end by line-offset do
+                 (subst-char-in-region pos (1+ pos) curr-char new-char)
+                 (hanoi-put-face pos (1+ pos) face))
+         (subst-char-in-region pole-start pole-end curr-char new-char)
+         (hanoi-put-face pole-start pole-end face))))
+    (setcar ring pos))
+  (hanoi-goto-char pos))
+
+;; Check if a buffer position lies on a tower (vis. in the fly row).
+(defun hanoi-pos-on-tower-p (pos)
+  (if hanoi-horizontal-flag
+      (/= (% pos fly-step) fly-row-start)
+    (>= pos (+ fly-row-start baseward-step))))
+
+(provide 'hanoi)
+
+;;; arch-tag: 7a901659-4346-495c-8883-14cbf540610c
+;;; hanoi.el ends here
similarity index 100%
rename from recursive-edit.lisp
rename to src/recursive-edit.lisp
similarity index 97%
rename from render.lisp
rename to src/render.lisp
index 3270c87..4c758dc 100644 (file)
@@ -30,7 +30,7 @@
                            ;; Figure out what part to display
                            (window-framer tree 
                                           (window-point tree)
-                                          (truncate (window-height tree) 2))
+                                          (truncate (window-height tree nil) 2))
                            (dformat +debug-vvv+ "after framer: ~a~%"
                                     (lc-cache (window-cache tree)))
                            ;; display it
similarity index 92%
rename from search.lisp
rename to src/search.lisp
index d1215c8..a4769f8 100644 (file)
@@ -43,6 +43,31 @@ Zero means the entire text matched by the whole regexp or whole string."
       (match-data-start data)
       (aref (match-data-reg-starts data) (1- idx))))
 
+(defun match-string (num &optional string)
+  "Return string of text matched by last search.
+NUM specifies which parenthesized expression in the last regexp.
+ Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
+Zero means the entire text matched by the whole regexp or whole string.
+STRING should be given if the last search was by `string-match' on STRING."
+  (if (match-beginning num)
+      (if string
+         (substring string (match-beginning num) (match-end num))
+          (buffer-substring (match-beginning num) (match-end num)))))
+
+
+(defun match-string-no-properties (num &optional string)
+  "Return string of text matched by last search, without text properties.
+NUM specifies which parenthesized expression in the last regexp.
+ Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
+Zero means the entire text matched by the whole regexp or whole string.
+STRING should be given if the last search was by `string-match' on STRING."
+  (if (match-beginning num)
+      (if string
+         (substring-no-properties string (match-beginning num)
+                                  (match-end num))
+          (buffer-substring-no-properties (match-beginning num)
+                                          (match-end num)))))
+
 ;; FIXME: needs a formatter and the search string
 (define-condition search-failed (lice-condition)
   () (:documentation "raised when a search failed to match"))
@@ -289,6 +314,15 @@ matched by the parenthesis constructions in regexp."
       collect c)
    'string))
 
+(defun wordify (string)
+  "Given a string of words separated by word delimiters,
+compute a regexp that matches those exact words
+separated by arbitrary punctuation."
+  (error "unimplemented"))
+
+(defun word-search-forward (string &key (bound (begv)) (error t) count &aux (buffer (current-buffer)))
+  (error "unimplemented"))
+
 (defun scan-buffer (buffer target start end count)
 "Search for COUNT instances of the character TARGET between START and END.
 
similarity index 100%
rename from subprocesses.lisp
rename to src/subprocesses.lisp
similarity index 100%
rename from syntax.lisp
rename to src/syntax.lisp
diff --git a/src/textmodes/fill.lisp b/src/textmodes/fill.lisp
new file mode 100644 (file)
index 0000000..4381cd8
--- /dev/null
@@ -0,0 +1,1461 @@
+;;; fill.el --- fill commands for Emacs                -*- coding: iso-2022-7bit -*-
+
+;; Copyright (C) 1985, 1986, 1992, 1994, 1995, 1996, 1997, 1999, 2001, 2002,
+;;   2003, 2004, 2005, 2006 Free Software Foundation, Inc.
+
+;; Maintainer: FSF
+;; Keywords: wp
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Commentary:
+
+;; All the commands for filling text.  These are documented in the Emacs
+;; manual.
+
+;;; Code:
+
+(in-package "LICE")
+
+(defgroup fill nil
+  "Indenting and filling text."
+  :link '(custom-manual "(emacs)Filling")
+  :group 'editing)
+
+(defcustom fill-individual-varying-indent nil
+  "*Controls criterion for a new paragraph in `fill-individual-paragraphs'.
+Non-nil means changing indent doesn't end a paragraph.
+That mode can handle paragraphs with extra indentation on the first line,
+but it requires separator lines between paragraphs.
+A value of nil means that any change in indentation starts a new paragraph."
+  :type 'boolean
+  :group 'fill)
+
+(defcustom colon-double-space nil
+  "*Non-nil means put two spaces after a colon when filling."
+  :type 'boolean
+  :group 'fill)
+;;;###autoload(put 'colon-double-space 'safe-local-variable 'booleanp)
+
+(defvar fill-paragraph-function nil
+  "Mode-specific function to fill a paragraph, or nil if there is none.
+If the function returns nil, then `fill-paragraph' does its normal work.")
+
+(defvar fill-paragraph-handle-comment t
+  "Non-nil means paragraph filling will try to pay attention to comments.")
+
+(defcustom enable-kinsoku t
+  "*Non-nil means enable \"kinsoku\" processing on filling paragraphs.
+Kinsoku processing is designed to prevent certain characters from being
+placed at the beginning or end of a line by filling.
+See the documentation of `kinsoku' for more information."
+  :type 'boolean
+  :group 'fill)
+
+(defun set-fill-prefix ()
+  "Set the fill prefix to the current line up to point.
+Filling expects lines to start with the fill prefix and
+reinserts the fill prefix in each resulting line."
+  (interactive)
+  (let ((left-margin-pos (save-excursion (move-to-left-margin) (point))))
+    (el:if (> (point) left-margin-pos)
+       (progn
+         (setq fill-prefix (buffer-substring left-margin-pos (point)))
+         (el:if (equal fill-prefix "")
+             (setq fill-prefix nil)))
+      (setq fill-prefix nil)))
+  (el:if fill-prefix
+      (message "fill-prefix: \"%s\"" fill-prefix)
+    (message "fill-prefix cancelled")))
+
+(defcustom adaptive-fill-mode t
+  "*Non-nil means determine a paragraph's fill prefix from its text."
+  :type 'boolean
+  :group 'fill)
+
+(defcustom adaptive-fill-regexp
+  ;; Added `!' for doxygen comments starting with `//!' or `/*!'.
+  ;; Added `%' for TeX comments.
+  ;; used to be this (purecopy "[ \t]*\\([-!|#%;>*\e,A7\e$,1s"s#sC\e$,2"F\e(B]+[ \t]*\\|(?[0-9]+[.)][ \t]*\\)*")
+  "[ \t]*\\([-!|#%;>*]+[ \t]*\\|(?[0-9]+[.)][ \t]*\\)*"
+  "*Regexp to match text at start of line that constitutes indentation.
+If Adaptive Fill mode is enabled, a prefix matching this pattern
+on the first and second lines of a paragraph is used as the
+standard indentation for the whole paragraph.
+
+If the paragraph has just one line, the indentation is taken from that
+line, but in that case `adaptive-fill-first-line-regexp' also plays
+a role."
+  :type 'regexp
+  :group 'fill)
+
+(defcustom adaptive-fill-first-line-regexp "\\`[ \t]*\\'"
+  "*Regexp specifying whether to set fill prefix from a one-line paragraph.
+When a paragraph has just one line, then after `adaptive-fill-regexp'
+finds the prefix at the beginning of the line, if it doesn't
+match this regexp, it is replaced with whitespace.
+
+By default, this regexp matches sequences of just spaces and tabs.
+
+However, we never use a prefix from a one-line paragraph
+if it would act as a paragraph-starter on the second line."
+  :type 'regexp
+  :group 'fill)
+
+(defcustom adaptive-fill-function nil
+  "*Function to call to choose a fill prefix for a paragraph, or nil.
+nil means the function has not determined the fill prefix."
+  :type '(choice (const nil) function)
+  :group 'fill)
+
+(defvar fill-indent-according-to-mode nil ;Screws up CC-mode's filling tricks.
+  "Whether or not filling should try to use the major mode's indentation.")
+
+(defun current-fill-column ()
+  "Return the fill-column to use for this line.
+The fill-column to use for a buffer is stored in the variable `fill-column',
+but can be locally modified by the `right-margin' text property, which is
+subtracted from `fill-column'.
+
+The fill column to use for a line is the first column at which the column
+number equals or exceeds the local fill-column - right-margin difference."
+  (save-excursion
+    (el:if fill-column
+       (let* ((here (progn (beginning-of-line) (point)))
+              (here-col 0)
+              (eol (progn (end-of-line) (point)))
+              margin fill-col change col)
+         ;; Look separately at each region of line with a different
+         ;; right-margin.
+         (while (and (setq margin (get-text-property here 'right-margin)
+                           fill-col (- fill-column (or margin 0))
+                           change (text-property-not-all
+                                   here eol 'right-margin margin))
+                     (progn (goto-char (1- change))
+                            (setq col (current-column))
+                            (< col fill-col)))
+           (setq here change
+                 here-col col))
+         (max here-col fill-col)))))
+
+(defun canonically-space-region (beg end)
+  "Remove extra spaces between words in region.
+Leave one space between words, two at end of sentences or after colons
+\(depending on values of `sentence-end-double-space', `colon-double-space',
+and `sentence-end-without-period').
+Remove indentation from each line."
+  (interactive "*r")
+  (let ((end-spc-re (concat "\\(" (sentence-end) "\\) *\\|  +")))
+    (save-excursion
+      (goto-char beg)
+      ;; Nuke tabs; they get screwed up in a fill.
+      ;; This is quick, but loses when a tab follows the end of a sentence.
+      ;; Actually, it is difficult to tell that from "Mr.\tSmith".
+      ;; Blame the typist.
+      (subst-char-in-region beg end #\Tab #\Space)
+      (while (and (< (point) end)
+                 (re-search-forward end-spc-re end t))
+       (delete-region
+        (cond
+         ;; `sentence-end' matched and did not match all spaces.
+         ;; I.e. it only matched the number of spaces it needs: drop the rest.
+         ((and (match-end 1) (> (match-end 0) (match-end 1)))  (match-end 1))
+         ;; `sentence-end' matched but with nothing left.  Either that means
+         ;; nothing should be removed, or it means it's the "old-style"
+         ;; sentence-end which matches all it can.  Keep only 2 spaces.
+         ;; We probably don't even need to check `sentence-end-double-space'.
+         ((match-end 1)
+          (min (match-end 0)
+               (+ (el:if sentence-end-double-space 2 1)
+                  (save-excursion (goto-char (match-end 0))
+                                  (skip-chars-backward " ")
+                                  (point)))))
+         (t ;; It's not an end of sentence.
+          (+ (match-beginning 0)
+             ;; Determine number of spaces to leave:
+             (save-excursion
+               (skip-chars-backward " ]})\"'")
+               (cond ((and sentence-end-double-space
+                           (or (memq (preceding-char) '(#\. #\? #\!))
+                               (and sentence-end-without-period
+                                    (eq (char-syntax (preceding-char)) :word-constituent)))) 2)
+                     ((and colon-double-space
+                           (char= (preceding-char) #\:))  2)
+                     ((char-equal (preceding-char) #\Newline)  0)
+                     (t 1))))))
+        (match-end 0))))))
+
+(defun fill-common-string-prefix (s1 s2)
+  "Return the longest common prefix of strings S1 and S2, or nil if none."
+  (let ((cmp (compare-strings s1 nil nil s2 nil nil)))
+    (el:if (eq cmp t)
+       s1
+      (setq cmp (1- (abs cmp)))
+      (unless (zerop cmp)
+       (substring s1 0 cmp)))))
+
+(defun fill-match-adaptive-prefix ()
+  (let ((str (or
+              (and adaptive-fill-function (funcall adaptive-fill-function))
+              (and adaptive-fill-regexp (looking-at adaptive-fill-regexp)
+                   (match-string-no-properties 0)))))
+    (el:if (>= (+ (current-left-margin) (length str)) (current-fill-column))
+        ;; Death to insanely long prefixes.
+        nil
+      str)))
+
+(defun fill-context-prefix (from to &optional first-line-regexp)
+  "Compute a fill prefix from the text between FROM and TO.
+This uses the variables `adaptive-fill-regexp' and `adaptive-fill-function'
+and `adaptive-fill-first-line-regexp'.  `paragraph-start' also plays a role;
+we reject a prefix based on a one-line paragraph if that prefix would
+act as a paragraph-separator."
+  (or first-line-regexp
+      (setq first-line-regexp adaptive-fill-first-line-regexp))
+  (save-excursion
+    (goto-char from)
+    (el:if (eolp) (forward-line 1))
+    ;; Move to the second line unless there is just one.
+    (move-to-left-margin)
+    (let (first-line-prefix
+         ;; Non-nil if we are on the second line.
+         second-line-prefix)
+      (setq first-line-prefix
+           ;; We don't need to consider `paragraph-start' here since it
+           ;; will be explicitly checked later on.
+           ;; Also setting first-line-prefix to nil prevents
+           ;; second-line-prefix from being used.
+           ;; ((looking-at paragraph-start) nil)
+           (fill-match-adaptive-prefix))
+      (forward-line 1)
+      (el:if (< (point) to)
+          (progn
+            (move-to-left-margin)
+            (setq second-line-prefix
+                  (cond ((looking-at paragraph-start) nil) ;Can it happen? -Stef
+                        (t (fill-match-adaptive-prefix))))
+            ;; If we get a fill prefix from the second line,
+            ;; make sure it or something compatible is on the first line too.
+            (when second-line-prefix
+              (unless first-line-prefix (setq first-line-prefix ""))
+              ;; If the non-whitespace chars match the first line,
+              ;; just use it (this subsumes the 2 checks used previously).
+              ;; Used when first line is `/* ...' and second-line is
+              ;; ` * ...'.
+              (let ((tmp second-line-prefix)
+                    (re "\\`"))
+                (while (string-match "\\`[ \t]*\\([^ \t]+\\)" tmp)
+                  (setq re (concat re ".*" (regexp-quote (match-string 1 tmp))))
+                  (setq tmp (substring tmp (match-end 0))))
+                ;; (assert (string-match "\\`[ \t]*\\'" tmp))
+
+                (el:if (string-match re first-line-prefix)
+                    second-line-prefix
+
+                  ;; Use the longest common substring of both prefixes,
+                  ;; if there is one.
+                  (fill-common-string-prefix first-line-prefix
+                                             second-line-prefix)))))
+       ;; If we get a fill prefix from a one-line paragraph,
+       ;; maybe change it to whitespace,
+       ;; and check that it isn't a paragraph starter.
+       (el:if first-line-prefix
+           (let ((result
+                  ;; If first-line-prefix comes from the first line,
+                  ;; see if it seems reasonable to use for all lines.
+                  ;; If not, replace it with whitespace.
+                  (el:if (or (and first-line-regexp
+                               (string-match first-line-regexp
+                                             first-line-prefix))
+                          (and comment-start-skip
+                               (string-match comment-start-skip
+                                             first-line-prefix)))
+                      first-line-prefix
+                    (make-string (string-width first-line-prefix) :initial-element #\Space))))
+             ;; But either way, reject it if it indicates the start
+             ;; of a paragraph when text follows it.
+             (el:if (not (eq 0 (string-match paragraph-start
+                                          (concat result "a"))))
+                 result)))))))
+
+(defun fill-single-word-nobreak-p ()
+  "Don't break a line after the first or before the last word of a sentence."
+  (or (looking-at (concat "[ \t]*\\sw+" "\\(?:" (sentence-end) "\\)"))
+      (save-excursion
+       (skip-chars-backward " \t")
+       (and (/= (skip-syntax-backward "w") 0)
+            (/= (skip-chars-backward " \t") 0)
+            (/= (skip-chars-backward ".?!:") 0)
+            (looking-at (sentence-end))))))
+
+(defun fill-french-nobreak-p ()
+  "Return nil if French style allows breaking the line at point.
+This is used in `fill-nobreak-predicate' to prevent breaking lines just
+after an opening paren or just before a closing paren or a punctuation
+mark such as `?' or `:'.  It is common in French writing to put a space
+at such places, which would normally allow breaking the line at those
+places."
+  (or (looking-at "[ \t]*[])}\e,A;\e,b;\e(B?!;:-]")
+      (save-excursion
+       (skip-chars-backward " \t")
+       (unless (bolp)
+         (backward-char 1)
+         (or (looking-at "[([{\e,A+\e,b+\e(B]")
+             ;; Don't cut right after a single-letter word.
+             (and (memq (preceding-char) '(#\Tab #\Space))
+                  (eq (char-syntax (following-char)) :word-constituent)))))))
+
+(defcustom fill-nobreak-predicate nil
+  "List of predicates for recognizing places not to break a line.
+The predicates are called with no arguments, with point at the place to
+be tested.  If it returns t, fill commands do not break the line there."
+  :group 'fill
+  :type 'hook
+  :options '(fill-french-nobreak-p fill-single-word-nobreak-p))
+
+(defcustom fill-nobreak-invisible nil
+  "Non-nil means that fill commands do not break lines in invisible text."
+  :type 'boolean
+  :group 'fill)
+
+(defun fill-nobreak-p ()
+  "Return nil if breaking the line at point is allowed.
+Can be customized with the variables `fill-nobreak-predicate'
+and `fill-nobreak-invisible'."
+  (or
+   (and fill-nobreak-invisible (line-move-invisible-p (point)))
+   (unless (bolp)
+    (or
+     ;; Don't break after a period followed by just one space.
+     ;; Move back to the previous place to break.
+     ;; The reason is that if a period ends up at the end of a
+     ;; line, further fills will assume it ends a sentence.
+     ;; If we now know it does not end a sentence, avoid putting
+     ;; it at the end of the line.
+     (and sentence-end-double-space
+         (save-excursion
+           (skip-chars-backward " ")
+           (and (char= (preceding-char) #\.)
+                (looking-at " \\([^ ]\\|$\\)"))))
+     ;; Another approach to the same problem.
+     (save-excursion
+       (skip-chars-backward " ")
+       (and (char= (preceding-char) #\.)
+           (not (progn (forward-char -1) (looking-at (sentence-end))))))
+     ;; Don't split a line if the rest would look like a new paragraph.
+     (unless use-hard-newlines
+       (save-excursion
+        (skip-chars-forward " \t")
+        ;; If this break point is at the end of the line,
+        ;; which can occur for auto-fill, don't consider the newline
+        ;; which follows as a reason to return t.
+        (and (not (eolp))
+             (looking-at paragraph-start))))
+     (run-hook-with-args-until-success 'fill-nobreak-predicate)))))
+
+;; ;; Put `fill-find-break-point-function' property to charsets which
+;; ;; require special functions to find line breaking point.
+;; (dolist (pair '((katakana-jisx0201 . kinsoku)
+;;             (chinese-gb2312 . kinsoku)
+;;             (japanese-jisx0208 . kinsoku)
+;;             (japanese-jisx0212 . kinsoku)
+;;             (chinese-big5-1 . kinsoku)
+;;             (chinese-big5-2 . kinsoku)))
+;;   (put-charset-property (car pair) 'fill-find-break-point-function (cdr pair)))
+
+(defun fill-find-break-point (limit)
+  "Move point to a proper line breaking position of the current line.
+Don't move back past the buffer position LIMIT.
+
+This function is called when we are going to break the current line
+after or before a non-ASCII character.  If the charset of the
+character has the property `fill-find-break-point-function', this
+function calls the property value as a function with one arg LINEBEG.
+If the charset has no such property, do nothing."
+  (let* ((ch (following-char))
+        (charset (char-charset ch))
+        func)
+    (el:if (eq charset 'ascii)
+       (setq ch (preceding-char)
+             charset (char-charset ch)))
+    (el:if (charsetp charset)
+       (setq func
+             (get-charset-property charset 'fill-find-break-point-function)))
+    (el:if (and func (fboundp func))
+       (funcall func limit))))
+
+(defun fill-delete-prefix (from to prefix)
+  "Delete the fill prefix from every line except the first.
+The first line may not even have a fill prefix.
+Point is moved to just past the fill prefix on the first line."
+  (let ((fpre (el:if (and prefix (not (string-match "\\`[ \t]*\\'" prefix)))
+                 (concat "[ \t]*\\("
+                         (replace-regexp-in-string
+                          "[ \t]+" "[ \t]*"
+                          (regexp-quote prefix))
+                         "\\)?[ \t]*")
+               "[ \t]*")))
+    (goto-char from)
+    ;; Why signal an error here?  The problem needs to be caught elsewhere.
+    ;; (el:if (>= (+ (current-left-margin) (length prefix))
+    ;;         (current-fill-column))
+    ;;     (error "fill-prefix too long for specified width"))
+    (forward-line 1)
+    (while (< (point) to)
+      (el:if (looking-at fpre)
+          (delete-region (point) (match-end 0)))
+      (forward-line 1))
+    (goto-char from)
+    (el:if (looking-at fpre)
+       (goto-char (match-end 0)))
+    (point)))
+
+;; The `fill-space' property carries the string with which a newline
+;; should be replaced when unbreaking a line (in fill-delete-newlines).
+;; It is added to newline characters by fill-newline when the default
+;; behavior of fill-delete-newlines is not what we want.
+(add-to-list '*text-property-default-nonsticky* '(fill-space . t))
+
+(defun fill-delete-newlines (from to justify nosqueeze squeeze-after)
+  (goto-char from)
+  ;; Make sure sentences ending at end of line get an extra space.
+  ;; loses on split abbrevs ("Mr.\nSmith")
+  (let ((eol-double-space-re
+        (cond
+         ((not colon-double-space) (concat (sentence-end) "$"))
+         ;; Try to add the : inside the `sentence-end' regexp.
+         ((string-match "\\[[^][]*\\(\\.\\)[^][]*\\]" (sentence-end))
+          (concat (replace-match ".:" nil nil (sentence-end) 1) "$"))
+         ;; Can't find the right spot to insert the colon.
+         (t "[.?!:][])}\"']*$")))
+       (sentence-end-without-space-list
+        (string-to-list sentence-end-without-space)))
+    (while (re-search-forward eol-double-space-re to t)
+      (or (>= (point) to) (memq (char-before) '(#\Tab #\Space))
+         (memq (char-after (match-beginning 0))
+               sentence-end-without-space-list)
+         (insert-and-inherit #\Space))))
+
+  (goto-char from)
+  (el:if enable-multibyte-characters
+      ;; Delete unnecessay newlines surrounded by words.  The
+      ;; character category `|' means that we can break a line
+      ;; at the character.  And, charset property
+      ;; `nospace-between-words' tells how to concatenate
+      ;; words.  If the value is non-nil, never put spaces
+      ;; between words, thus delete a newline between them.
+      ;; If the value is nil, delete a newline only when a
+      ;; character preceding a newline has text property
+      ;; `nospace-between-words'.
+      (while (search-forward "\n" to t)
+       (el:if (get-text-property (match-beginning 0) 'fill-space)
+           (replace-match (get-text-property (match-beginning 0) 'fill-space))
+         (let ((prev (char-before (match-beginning 0)))
+               (next (following-char)))
+           (el:if (and (or (aref (char-category-set next) (char-code #\|))
+                        (aref (char-category-set prev) (char-code #\|)))
+                    (or (get-charset-property (char-charset prev)
+                                              'nospace-between-words)
+                        (get-text-property (1- (match-beginning 0))
+                                           'nospace-between-words)))
+               (delete-char -1))))))
+
+  (goto-char from)
+  (skip-chars-forward " \t")
+  ;; Then change all newlines to spaces.
+  (subst-char-in-region from to #\Newline #\Space)
+  (el:if (and nosqueeze (not (eq justify 'full)))
+      nil
+    (canonically-space-region (or squeeze-after (point)) to)
+    ;; Remove trailing whitespace.
+    ;; Maybe canonically-space-region should do that.
+    (goto-char to) (delete-char (- (skip-chars-backward " \t"))))
+  (goto-char from))
+
+(defun fill-move-to-break-point (linebeg)
+  "Move to the position where the line should be broken.
+The break position will be always after LINEBEG and generally before point."
+  ;; If the fill column is before linebeg, move to linebeg.
+  (el:if (> linebeg (point)) (goto-char linebeg))
+  ;; Move back to the point where we can break the line
+  ;; at.  We break the line between word or after/before
+  ;; the character which has character category `|'.  We
+  ;; search space, \c| followed by a character, or \c|
+  ;; following a character.  If not found, place
+  ;; the point at linebeg.
+  (while
+      (when (re-search-backward "[ \t]\\|\\c|.\\|.\\c|" linebeg 0)
+       ;; In case of space, we place the point at next to
+       ;; the point where the break occurs actually,
+       ;; because we don't want to change the following
+       ;; logic of original Emacs.  In case of \c|, the
+       ;; point is at the place where the break occurs.
+       (forward-char 1)
+       (when (fill-nobreak-p) (skip-chars-backward " \t" linebeg))))
+
+  ;; Move back over the single space between the words.
+  (skip-chars-backward " \t")
+
+  ;; If the left margin and fill prefix by themselves
+  ;; pass the fill-column. or if they are zero
+  ;; but we have no room for even one word,
+  ;; keep at least one word or a character which has
+  ;; category `|' anyway.
+  (el:if (>= linebeg (point))
+      ;; Ok, skip at least one word or one \c| character.
+      ;; Meanwhile, don't stop at a period followed by one space.
+      (let ((to (line-end-position))
+           (fill-nobreak-predicate nil) ;to break sooner.
+           (first t))
+       (goto-char linebeg)
+       (while (and (< (point) to) (or first (fill-nobreak-p)))
+         ;; Find a breakable point while ignoring the
+         ;; following spaces.
+         (skip-chars-forward " \t")
+         (el:if (looking-at "\\c|")
+             (forward-char 1)
+           (let ((pos (save-excursion
+                        (skip-chars-forward "^ \n\t")
+                        (point))))
+             (el:if (re-search-forward "\\c|" pos t)
+                 (forward-char -1)
+               (goto-char pos))))
+         (setq first nil)))
+
+    (el:if enable-multibyte-characters
+       ;; If we are going to break the line after or
+       ;; before a non-ascii character, we may have to
+       ;; run a special function for the charset of the
+       ;; character to find the correct break point.
+       (el:if (not (and (eq (charset-after (1- (point))) 'ascii)
+                     (eq (charset-after (point)) 'ascii)))
+           ;; Make sure we take SOMETHING after the fill prefix if any.
+           (fill-find-break-point linebeg)))))
+
+;; Like text-properties-at but don't include `composition' property.
+(defun fill-text-properties-at (pos)
+  (let ((l (text-properties-at pos))
+       prop-list)
+    (while l
+      (unless (eq (car l) 'composition)
+       (setq prop-list
+             (cons (car l) (cons (cadr l) prop-list))))
+      (setq l (cddr l)))
+    prop-list))
+
+(defun fill-newline ()
+  ;; Replace whitespace here with one newline, then
+  ;; indent to left margin.
+  (skip-chars-backward " \t")
+  (insert #\Newline)
+  ;; Give newline the properties of the space(s) it replaces
+  (set-text-properties (1- (point)) (point)
+                      (fill-text-properties-at (point)))
+  (and (looking-at "( [ \t]*)(\\c|)?")
+       (or (aref (char-category-set (or (char-before (1- (point))) #\Nul)) (char-code #\|))
+          (match-end 2))
+       ;; When refilling later on, this newline would normally not be replaced
+       ;; by a space, so we need to mark it specially to re-install the space
+       ;; when we unfill.
+       (put-text-property (1- (point)) (point) 'fill-space (match-string 1)))
+  ;; If we don't want breaks in invisible text, don't insert
+  ;; an invisible newline.
+  (el:if fill-nobreak-invisible
+      (remove-text-properties (1- (point)) (point)
+                             '(invisible t)))
+  (el:if (or fill-prefix
+         (not fill-indent-according-to-mode))
+      (fill-indent-to-left-margin)
+    (indent-according-to-mode))
+  ;; Insert the fill prefix after indentation.
+  (and fill-prefix (not (equal fill-prefix ""))
+       ;; Markers that were after the whitespace are now at point: insert
+       ;; before them so they don't get stuck before the prefix.
+       (insert-before-markers-and-inherit fill-prefix)))
+
+(defun fill-indent-to-left-margin ()
+  "Indent current line to the column given by `current-left-margin'."
+  (let ((beg (point)))
+    (indent-line-to (current-left-margin))
+    (put-text-property beg (point) 'face 'default)))
+
+(defun fill-region-as-paragraph (from to &optional justify
+                                     nosqueeze squeeze-after)
+  "Fill the region as one paragraph.
+It removes any paragraph breaks in the region and extra newlines at the end,
+indents and fills lines between the margins given by the
+`current-left-margin' and `current-fill-column' functions.
+\(In most cases, the variable `fill-column' controls the width.)
+It leaves point at the beginning of the line following the paragraph.
+
+Normally performs justification according to the `current-justification'
+function, but with a prefix arg, does full justification instead.
+
+From a program, optional third arg JUSTIFY can specify any type of
+justification.  Fourth arg NOSQUEEZE non-nil means not to make spaces
+between words canonical before filling.  Fifth arg SQUEEZE-AFTER, if non-nil,
+means don't canonicalize spaces before that position.
+
+Return the `fill-prefix' used for filling.
+
+If `sentence-end-double-space' is non-nil, then period followed by one
+space does not end a sentence, so don't break a line there."
+  (interactive (progn
+                (barf-if-buffer-read-only)
+                (list (region-beginning) (region-end)
+                      (el:if current-prefix-arg 'full))))
+  (unless (memq justify '(t nil none full center left right))
+    (setq justify 'full))
+
+  ;; Make sure "to" is the endpoint.
+  (goto-char (min from to))
+  (setq to   (max from to))
+  ;; Ignore blank lines at beginning of region.
+  (skip-chars-forward " \t\n")
+
+  (let ((from-plus-indent (point))
+       (oneleft nil))
+
+    (beginning-of-line)
+    ;; We used to round up to whole line, but that prevents us from
+    ;; correctly handling filling of mixed code-and-comment where we do want
+    ;; to fill the comment but not the code.  So only use (point) if it's
+    ;; further than `from', which means that `from' is followed by some
+    ;; number of empty lines.
+    (setq from (max (point) from))
+
+    ;; Delete all but one soft newline at end of region.
+    ;; And leave TO before that one.
+    (goto-char to)
+    (while (and (> (point) from) (eq #\Newline (char-after (1- (point)))))
+      (el:if (and oneleft
+              (not (and use-hard-newlines
+                        (get-text-property (1- (point)) 'hard))))
+         (delete-backward-char 1)
+       (backward-char 1)
+       (setq oneleft t)))
+    (setq to (copy-marker (point) t))
+    ;; ;; If there was no newline, and there is text in the paragraph, then
+    ;; ;; create a newline.
+    ;; (el:if (and (not oneleft) (> to from-plus-indent))
+    ;;         (newline))
+    (goto-char from-plus-indent))
+
+  (el:if (not (> to (point)))
+      nil ;; There is no paragraph, only whitespace: exit now.
+
+    (or justify (setq justify (current-justification)))
+
+    ;; Don't let Adaptive Fill mode alter the fill prefix permanently.
+    (let ((fill-prefix fill-prefix))
+      ;; Figure out how this paragraph is indented, if desired.
+      (when (and adaptive-fill-mode
+                (or (null fill-prefix) (string= fill-prefix "")))
+       (setq fill-prefix (fill-context-prefix from to))
+       ;; Ignore a white-space only fill-prefix
+       ;; if we indent-according-to-mode.
+       (when (and fill-prefix fill-indent-according-to-mode
+                  (string-match "\\`[ \t]*\\'" fill-prefix))
+         (setq fill-prefix nil)))
+
+      (goto-char from)
+      (beginning-of-line)
+
+      (el:if (not justify)       ; filling disabled: just check indentation
+         (progn
+           (goto-char from)
+           (while (< (point) to)
+             (el:if (and (not (eolp))
+                      (< (current-indentation) (current-left-margin)))
+                 (fill-indent-to-left-margin))
+             (forward-line 1)))
+
+       (el:if use-hard-newlines
+           (remove-list-of-text-properties from to '(hard)))
+       ;; Make sure first line is indented (at least) to left margin...
+       (el:if (or (memq justify '(right center))
+               (< (current-indentation) (current-left-margin)))
+           (fill-indent-to-left-margin))
+       ;; Delete the fill-prefix from every line.
+       (fill-delete-prefix from to fill-prefix)
+       (setq from (point))
+
+       ;; FROM, and point, are now before the text to fill,
+       ;; but after any fill prefix on the first line.
+
+       (fill-delete-newlines from to justify nosqueeze squeeze-after)
+
+       ;; This is the actual filling loop.
+       (goto-char from)
+       (let (linebeg)
+         (while (< (point) to)
+           (setq linebeg (point))
+           (move-to-column (current-fill-column))
+           (el:if (when (< (point) to)
+                 ;; Find the position where we'll break the line.
+                 (forward-char 1) ;Use an immediately following space, if any.
+                 (fill-move-to-break-point linebeg)
+                 ;; Check again to see if we got to the end of
+                 ;; the paragraph.
+                 (skip-chars-forward " \t")
+                 (< (point) to))
+               ;; Found a place to cut.
+               (progn
+                 (fill-newline)
+                 (when justify
+                   ;; Justify the line just ended, if desired.
+                   (save-excursion
+                     (forward-line -1)
+                     (justify-current-line justify nil t))))
+
+             (goto-char to)
+             ;; Justify this last line, if desired.
+             (el:if justify (justify-current-line justify t t))))))
+      ;; Leave point after final newline.
+      (goto-char to)
+      (unless (eobp) (forward-char 1))
+      ;; Return the fill-prefix we used
+      fill-prefix)))
+
+(defsubst skip-line-prefix (prefix)
+  "If point is inside the string PREFIX at the beginning of line, move past it."
+  (when (and prefix
+            (< (- (point) (line-beginning-position)) (length prefix))
+            (save-excursion
+              (beginning-of-line)
+              (looking-at (regexp-quote prefix))))
+    (goto-char (match-end 0))))
+
+(defun fill-paragraph (arg)
+  "Fill paragraph at or after point.  Prefix ARG means justify as well.
+If `sentence-end-double-space' is non-nil, then period followed by one
+space does not end a sentence, so don't break a line there.
+the variable `fill-column' controls the width for filling.
+
+If `fill-paragraph-function' is non-nil, we call it (passing our
+argument to it), and if it returns non-nil, we simply return its value.
+
+If `fill-paragraph-function' is nil, return the `fill-prefix' used for filling."
+  (interactive (progn
+                (barf-if-buffer-read-only)
+                (list (el:if current-prefix-arg 'full))))
+  ;; First try fill-paragraph-function.
+  (or (and fill-paragraph-function
+          (let ((function fill-paragraph-function)
+                ;; If fill-paragraph-function is set, it probably takes care
+                ;; of comments and stuff.  If not, it will have to set
+                ;; fill-paragraph-handle-comment back to t explicitly or
+                ;; return nil.
+                (fill-paragraph-handle-comment nil)
+                fill-paragraph-function)
+            (funcall function arg)))
+      ;; Then try our syntax-aware filling code.
+      (and fill-paragraph-handle-comment
+          ;; Our code only handles \n-terminated comments right now.
+          comment-start (equal comment-end "")
+          (let ((fill-paragraph-handle-comment nil))
+            (fill-comment-paragraph arg)))
+      ;; If it all fails, default to the good ol' text paragraph filling.
+      (let ((before (point))
+           (paragraph-start paragraph-start)
+           ;; Fill prefix used for filling the paragraph.
+           fill-pfx)
+       ;; Try to prevent code sections and comment sections from being
+       ;; filled together.
+       (when (and fill-paragraph-handle-comment comment-start-skip)
+         (setq paragraph-start
+               (concat paragraph-start "\\|[ \t]*\\(?:"
+                       comment-start-skip "\\)")))
+       (save-excursion
+         ;; To make sure the return value of forward-paragraph is meaningful,
+         ;; we have to start from the beginning of line, otherwise skipping
+         ;; past the last few chars of a paragraph-separator would count as
+         ;; a paragraph (and not skipping any chars at EOB would not count
+         ;; as a paragraph even if it is).
+         (move-to-left-margin)
+         (el:if (not (zerop (forward-paragraph)))
+             ;; There's no paragraph at or after point: give up.
+             (setq fill-pfx "")
+           (let ((end (point))
+                 (beg (progn (backward-paragraph) (point))))
+             (goto-char before)
+             (setq fill-pfx
+                   (el:if use-hard-newlines
+                       ;; Can't use fill-region-as-paragraph, since this
+                       ;; paragraph may still contain hard newlines.  See
+                       ;; fill-region.
+                       (fill-region beg end arg)
+                     (fill-region-as-paragraph beg end arg))))))
+       fill-pfx)))
+
+(defun fill-comment-paragraph (&optional justify)
+  "Fill current comment.
+If we're not in a comment, just return nil so that the caller
+can take care of filling.  JUSTIFY is used as in `fill-paragraph'."
+  (comment-normalize-vars)
+  (let (has-code-and-comment ; Non-nil if it contains code and a comment.
+       comin comstart)
+    ;; Figure out what kind of comment we are looking at.
+    (save-excursion
+      (beginning-of-line)
+      (when (setq comstart (comment-search-forward (line-end-position) t))
+       (setq comin (point))
+       (goto-char comstart) (skip-chars-backward " \t")
+       (setq has-code-and-comment (not (bolp)))))
+
+    (el:if (not comstart)
+       ;; Return nil, so the normal filling will take place.
+       nil
+
+      ;; Narrow to include only the comment, and then fill the region.
+      (let* ((fill-prefix fill-prefix)
+            (commark
+             (comment-string-strip (buffer-substring comstart comin) nil t))
+            (comment-re
+             (el:if (string-match comment-start-skip (concat commark "a"))
+                 (concat "[ \t]*" (regexp-quote commark)
+                         ;; Make sure we only match comments that use
+                         ;; the exact same comment marker.
+                         "[^" (substring commark -1) "]")
+               ;; If the commark needs to be followed by some special
+               ;; set of characters (like @c in TeXinfo), we can't
+               ;; rely just on `commark'.
+               (concat "[ \t]*\\(?:" comment-start-skip "\\)")))
+            (comment-fill-prefix       ; Compute a fill prefix.
+             (save-excursion
+               (goto-char comstart)
+               (el:if has-code-and-comment
+                   (concat
+                    (el:if (not indent-tabs-mode)
+                        (make-string (current-column) :initial-element #\Space)
+                      (concat
+                       (make-string (/ (current-column) tab-width) :initial-element #\Tab)
+                       (make-string (% (current-column) tab-width) :initial-element #\Space)))
+                    (buffer-substring (point) comin))
+                 (buffer-substring (line-beginning-position) comin))))
+            beg end)
+       (save-excursion
+         (save-restriction
+           (beginning-of-line)
+           (narrow-to-region
+            ;; Find the first line we should include in the region to fill.
+            (el:if has-code-and-comment
+                (line-beginning-position)
+              (save-excursion
+                (while (and (zerop (forward-line -1))
+                            (looking-at comment-re)))
+                ;; We may have gone too far.  Go forward again.
+                (line-beginning-position
+                 (el:if (progn
+                       (goto-char
+                        (or (comment-search-forward (line-end-position) t)
+                            (point)))
+                       (looking-at comment-re))
+                     (progn (setq comstart (point)) 1)
+                   (progn (setq comstart (point)) 2)))))
+            ;; Find the beginning of the first line past the region to fill.
+            (save-excursion
+              (while (progn (forward-line 1)
+                            (looking-at comment-re)))
+              (point)))
+           ;; Obey paragraph starters and boundaries within comments.
+           (let* ((paragraph-separate
+                   ;; Use the default values since they correspond to
+                   ;; the values to use for plain text.
+                   (concat paragraph-separate "\\|[ \t]*\\(?:"
+                           comment-start-skip "\\)\\(?:"
+                           (default-value 'paragraph-separate) "\\)"))
+                  (paragraph-start
+                   (concat paragraph-start "\\|[ \t]*\\(?:"
+                           comment-start-skip "\\)\\(?:"
+                           (default-value 'paragraph-start) "\\)"))
+                  ;; We used to rely on fill-prefix to break paragraph at
+                  ;; comment-starter changes, but it did not work for the
+                  ;; first line (mixed comment&code).
+                  ;; We now use comment-re instead to "manually" make sure
+                  ;; we treat comment-marker changes as paragraph boundaries.
+                  ;; (paragraph-ignore-fill-prefix nil)
+                  ;; (fill-prefix comment-fill-prefix)
+                  (after-line (el:if has-code-and-comment
+                                  (line-beginning-position 2))))
+             (setq end (progn (forward-paragraph) (point)))
+             ;; If this comment starts on a line with code,
+             ;; include that line in the filling.
+             (setq beg (progn (backward-paragraph)
+                              (el:if (eq (point) after-line)
+                                  (forward-line -1))
+                              (point)))))
+
+         ;; Find the fill-prefix to use.
+         (cond
+          (fill-prefix)          ; Use the user-provided fill prefix.
+          ((and adaptive-fill-mode     ; Try adaptive fill mode.
+                (setq fill-prefix (fill-context-prefix beg end))
+                (string-match comment-start-skip fill-prefix)))
+          (t
+           (setq fill-prefix comment-fill-prefix)))
+
+         ;; Don't fill with narrowing.
+         (or
+          (fill-region-as-paragraph
+           (max comstart beg) end justify nil
+           ;; Don't canonicalize spaces within the code just before
+           ;; the comment.
+           (save-excursion
+             (goto-char beg)
+             (el:if (looking-at fill-prefix)
+                 nil
+               (re-search-forward comment-start-skip))))
+          ;; Make sure we don't return nil.
+          t))))))
+
+(defun fill-region (from to &optional justify nosqueeze to-eop)
+  "Fill each of the paragraphs in the region.
+A prefix arg means justify as well.
+Ordinarily the variable `fill-column' controls the width.
+
+Noninteractively, the third argument JUSTIFY specifies which
+kind of justification to do: `full', `left', `right', `center',
+or `none' (equivalent to nil).  t means handle each paragraph
+as specified by its text properties.
+
+The fourth arg NOSQUEEZE non-nil means to leave
+whitespace other than line breaks untouched, and fifth arg TO-EOP
+non-nil means to keep filling to the end of the paragraph (or next
+hard newline, if variable `use-hard-newlines' is on).
+
+Return the fill-prefix used for filling the last paragraph.
+
+If `sentence-end-double-space' is non-nil, then period followed by one
+space does not end a sentence, so don't break a line there."
+  (interactive (progn
+                (barf-if-buffer-read-only)
+                (list (region-beginning) (region-end)
+                      (el:if current-prefix-arg 'full))))
+  (unless (memq justify '(t nil none full center left right))
+    (setq justify 'full))
+  (let (max beg fill-pfx)
+    (goto-char (max from to))
+    (when to-eop
+      (skip-chars-backward "\n")
+      (forward-paragraph))
+    (setq max (copy-marker (point) t))
+    (goto-char (setq beg (min from to)))
+    (beginning-of-line)
+    (while (< (point) max)
+      (let ((initial (point))
+           end)
+       ;; If using hard newlines, break at every one for filling
+       ;; purposes rather than using paragraph breaks.
+       (el:if use-hard-newlines
+           (progn
+             (while (and (setq end (text-property-any (point) max
+                                                      'hard t))
+                         (not (char= #\Newline (char-after end)))
+                         (not (>= end max)))
+               (goto-char (1+ end)))
+             (setq end (el:if end (min max (1+ end)) max))
+             (goto-char initial))
+         (forward-paragraph 1)
+         (setq end (min max (point)))
+         (forward-paragraph -1))
+       (el:if (< (point) beg)
+           (goto-char beg))
+       (el:if (>= (point) initial)
+           (setq fill-pfx
+                 (fill-region-as-paragraph (point) end justify nosqueeze))
+         (goto-char end))))
+    fill-pfx))
+
+\f
+(defcustom default-justification 'left
+  "*Method of justifying text not otherwise specified.
+Possible values are `left', `right', `full', `center', or `none'.
+The requested kind of justification is done whenever lines are filled.
+The `justification' text-property can locally override this variable."
+  :type '(choice (const left)
+                (const right)
+                (const full)
+                (const center)
+                (const none))
+  :group 'fill)
+(make-variable-buffer-local 'default-justification)
+
+(defun current-justification ()
+  "How should we justify this line?
+This returns the value of the text-property `justification',
+or the variable `default-justification' if there is no text-property.
+However, it returns nil rather than `none' to mean \"don't justify\"."
+  (let ((j (or (get-text-property
+               ;; Make sure we're looking at paragraph body.
+               (save-excursion (skip-chars-forward " \t")
+                               (el:if (and (eobp) (not (bobp)))
+                                   (1- (point)) (point)))
+               'justification)
+              default-justification)))
+    (el:if (eq 'none j)
+       nil
+      j)))
+
+(defun set-justification (begin end style &optional whole-par)
+  "Set the region's justification style to STYLE.
+This commands prompts for the kind of justification to use.
+If the mark is not active, this command operates on the current paragraph.
+If the mark is active, it operates on the region.  However, if the
+beginning and end of the region are not at paragraph breaks, they are
+moved to the beginning and end \(respectively) of the paragraphs they
+are in.
+
+If variable `use-hard-newlines' is true, all hard newlines are
+taken to be paragraph breaks.
+
+When calling from a program, operates just on region between BEGIN and END,
+unless optional fourth arg WHOLE-PAR is non-nil.  In that case bounds are
+extended to include entire paragraphs as in the interactive command."
+  (interactive (list (el:if mark-active (region-beginning) (point))
+                    (el:if mark-active (region-end) (point))
+                    (let ((s (completing-read
+                              "Set justification to: "
+                              '(("left") ("right") ("full")
+                                ("center") ("none"))
+                              nil t)))
+                      (el:if (equal s "") (error ""))
+                      (intern s))
+                    t))
+  (save-excursion
+    (save-restriction
+      (el:if whole-par
+         (let ((paragraph-start (el:if use-hard-newlines "." paragraph-start))
+               (paragraph-ignore-fill-prefix (el:if use-hard-newlines t
+                                               paragraph-ignore-fill-prefix)))
+           (goto-char begin)
+           (while (and (bolp) (not (eobp))) (forward-char 1))
+           (backward-paragraph)
+           (setq begin (point))
+           (goto-char end)
+           (skip-chars-backward " \t\n" begin)
+           (forward-paragraph)
+           (setq end (point))))
+
+      (narrow-to-region (point-min) end)
+      (unjustify-region begin (point-max))
+      (put-text-property begin (point-max) 'justification style)
+      (fill-region begin (point-max) nil t))))
+
+(defun set-justification-none (b e)
+  "Disable automatic filling for paragraphs in the region.
+If the mark is not active, this applies to the current paragraph."
+  (interactive (list (el:if mark-active (region-beginning) (point))
+                    (el:if mark-active (region-end) (point))))
+  (set-justification b e 'none t))
+
+(defun set-justification-left (b e)
+  "Make paragraphs in the region left-justified.
+This means they are flush at the left margin and ragged on the right.
+This is usually the default, but see the variable `default-justification'.
+If the mark is not active, this applies to the current paragraph."
+  (interactive (list (el:if mark-active (region-beginning) (point))
+                    (el:if mark-active (region-end) (point))))
+  (set-justification b e 'left t))
+
+(defun set-justification-right (b e)
+  "Make paragraphs in the region right-justified.
+This means they are flush at the right margin and ragged on the left.
+If the mark is not active, this applies to the current paragraph."
+  (interactive (list (el:if mark-active (region-beginning) (point))
+                    (el:if mark-active (region-end) (point))))
+  (set-justification b e 'right t))
+
+(defun set-justification-full (b e)
+  "Make paragraphs in the region fully justified.
+This makes lines flush on both margins by inserting spaces between words.
+If the mark is not active, this applies to the current paragraph."
+  (interactive (list (el:if mark-active (region-beginning) (point))
+                    (el:if mark-active (region-end) (point))))
+  (set-justification b e 'full t))
+
+(defun set-justification-center (b e)
+  "Make paragraphs in the region centered.
+If the mark is not active, this applies to the current paragraph."
+  (interactive (list (el:if mark-active (region-beginning) (point))
+                    (el:if mark-active (region-end) (point))))
+  (set-justification b e 'center t))
+
+;; A line has up to six parts:
+;;
+;;           >>>                    hello.
+;; [Indent-1][FP][    Indent-2     ][text][trailing whitespace][newline]
+;;
+;; "Indent-1" is the left-margin indentation; normally it ends at column
+;;     given by the `current-left-margin' function.
+;; "FP" is the fill-prefix.  It can be any string, including whitespace.
+;; "Indent-2" is added to justify a line if the `current-justification' is
+;;     `center' or `right'.  In `left' and `full' justification regions, any
+;;     whitespace there is part of the line's text, and should not be changed.
+;; Trailing whitespace is not counted as part of the line length when
+;; center- or right-justifying.
+;;
+;; All parts of the line are optional, although the final newline can
+;;     only be missing on the last line of the buffer.
+
+(defun justify-current-line (&optional how eop nosqueeze)
+  "Do some kind of justification on this line.
+Normally does full justification: adds spaces to the line to make it end at
+the column given by `current-fill-column'.
+Optional first argument HOW specifies alternate type of justification:
+it can be `left', `right', `full', `center', or `none'.
+If HOW is t, will justify however the `current-justification' function says to.
+If HOW is nil or missing, full justification is done by default.
+Second arg EOP non-nil means that this is the last line of the paragraph, so
+it will not be stretched by full justification.
+Third arg NOSQUEEZE non-nil means to leave interior whitespace unchanged,
+otherwise it is made canonical."
+  (interactive "*")
+  (el:if (eq t how) (setq how (or (current-justification) 'none))
+    (el:if (null how) (setq how 'full)
+      (or (memq how '(none left right center))
+         (setq how 'full))))
+  (or (memq how '(none left))  ; No action required for these.
+      (let ((fc (current-fill-column))
+           (pos (point-marker))
+           fp-end                      ; point at end of fill prefix
+           beg                         ; point at beginning of line's text
+           end                         ; point at end of line's text
+           indent                      ; column of `beg'
+           endcol                      ; column of `end'
+           ncols                       ; new indent point or offset
+           (nspaces 0)                 ; number of spaces between words
+                                       ; in line (not space characters)
+           (curr-fracspace 0)          ; current fractional space amount
+           count)
+       (end-of-line)
+       ;; Check if this is the last line of the paragraph.
+       (el:if (and use-hard-newlines (null eop)
+                (get-text-property (point) 'hard))
+           (setq eop t))
+       (skip-chars-backward " \t")
+       ;; Quick exit if it appears to be properly justified already
+       ;; or there is no text.
+       (el:if (or (bolp)
+               (and (memq how '(full right))
+                    (= (current-column) fc)))
+           nil
+         (setq end (point))
+         (beginning-of-line)
+         (skip-chars-forward " \t")
+         ;; Skip over fill-prefix.
+         (el:if (and fill-prefix
+                  (not (string-equal fill-prefix ""))
+                  (equal fill-prefix
+                         (buffer-substring
+                          (point) (min (point-max) (+ (length fill-prefix)
+                                                      (point))))))
+             (forward-char (length fill-prefix))
+           (el:if (and adaptive-fill-mode
+                    (looking-at adaptive-fill-regexp))
+               (goto-char (match-end 0))))
+         (setq fp-end (point))
+         (skip-chars-forward " \t")
+         ;; This is beginning of the line's text.
+         (setq indent (current-column))
+         (setq beg (point))
+         (goto-char end)
+         (setq endcol (current-column))
+
+         ;; HOW can't be null or left--we would have exited already
+         (cond ((eq 'right how)
+                (setq ncols (- fc endcol))
+                (el:if (< ncols 0)
+                    ;; Need to remove some indentation
+                    (delete-region
+                     (progn (goto-char fp-end)
+                            (el:if (< (current-column) (+ indent ncols))
+                                (move-to-column (+ indent ncols) t))
+                            (point))
+                     (progn (move-to-column indent) (point)))
+                  ;; Need to add some
+                  (goto-char beg)
+                  (indent-to (+ indent ncols))
+                  ;; If point was at beginning of text, keep it there.
+                  (el:if (= beg pos)
+                      (set-marker pos (point)))))
+
+               ((eq 'center how)
+                ;; Figure out how much indentation is needed
+                (setq ncols (+ (current-left-margin)
+                               (/ (- fc (current-left-margin) ;avail. space
+                                     (- endcol indent)) ;text width
+                                  2)))
+                (el:if (< ncols indent)
+                    ;; Have too much indentation - remove some
+                    (delete-region
+                     (progn (goto-char fp-end)
+                            (el:if (< (current-column) ncols)
+                                (move-to-column ncols t))
+                            (point))
+                     (progn (move-to-column indent) (point)))
+                  ;; Have too little - add some
+                  (goto-char beg)
+                  (indent-to ncols)
+                  ;; If point was at beginning of text, keep it there.
+                  (el:if (= beg pos)
+                      (set-marker pos (point)))))
+
+               ((eq 'full how)
+                ;; Insert extra spaces between words to justify line
+                (save-restriction
+                  (narrow-to-region beg end)
+                  (or nosqueeze
+                      (canonically-space-region beg end))
+                  (goto-char (point-max))
+                  ;; count word spaces in line
+                  (while (search-backward " " nil t)
+                    (setq nspaces (1+ nspaces))
+                    (skip-chars-backward " "))
+                  (setq ncols (- fc endcol))
+                  ;; Ncols is number of additional space chars needed
+                  (el:if (and (> ncols 0) (> nspaces 0) (not eop))
+                      (progn
+                        (setq curr-fracspace (+ ncols (/ (1+ nspaces) 2))
+                              count nspaces)
+                        (while (> count 0)
+                          (skip-chars-forward " ")
+                          (insert-and-inherit
+                           (make-string (/ curr-fracspace nspaces) :initial-element #\Space))
+                          (search-forward " " nil t)
+                          (setq count (1- count)
+                                curr-fracspace
+                                  (+ (% curr-fracspace nspaces) ncols)))))))
+               (t (error "Unknown justification value"))))
+       (goto-char pos)
+       (set-marker pos nil)))
+  nil)
+
+(defun unjustify-current-line ()
+  "Remove justification whitespace from current line.
+If the line is centered or right-justified, this function removes any
+indentation past the left margin.  If the line is full-justified, it removes
+extra spaces between words.  It does nothing in other justification modes."
+  (let ((justify (current-justification)))
+    (cond ((eq 'left justify) nil)
+         ((eq  nil  justify) nil)
+         ((eq 'full justify)           ; full justify: remove extra spaces
+          (beginning-of-line-text)
+          (canonically-space-region (point) (line-end-position)))
+         ((memq justify '(center right))
+          (save-excursion
+            (move-to-left-margin nil t)
+            ;; Position ourselves after any fill-prefix.
+            (el:if (and fill-prefix
+                     (not (string-equal fill-prefix ""))
+                     (equal fill-prefix
+                            (buffer-substring
+                             (point) (min (point-max) (+ (length fill-prefix)
+                                                         (point))))))
+                (forward-char (length fill-prefix)))
+            (delete-region (point) (progn (skip-chars-forward " \t")
+                                          (point))))))))
+
+(defun unjustify-region (&optional begin end)
+  "Remove justification whitespace from region.
+For centered or right-justified regions, this function removes any indentation
+past the left margin from each line.  For full-justified lines, it removes
+extra spaces between words.  It does nothing in other justification modes.
+Arguments BEGIN and END are optional; default is the whole buffer."
+  (save-excursion
+    (save-restriction
+      (el:if end (narrow-to-region (point-min) end))
+      (goto-char (or begin (point-min)))
+      (while (not (eobp))
+       (unjustify-current-line)
+       (forward-line 1)))))
+
+\f
+(defun fill-nonuniform-paragraphs (min max &optional justifyp citation-regexp)
+  "Fill paragraphs within the region, allowing varying indentation within each.
+This command divides the region into \"paragraphs\",
+only at paragraph-separator lines, then fills each paragraph
+using as the fill prefix the smallest indentation of any line
+in the paragraph.
+
+When calling from a program, pass range to fill as first two arguments.
+
+Optional third and fourth arguments JUSTIFYP and CITATION-REGEXP:
+JUSTIFYP to justify paragraphs (prefix arg).
+When filling a mail message, pass a regexp for CITATION-REGEXP
+which will match the prefix of a line which is a citation marker
+plus whitespace, but no other kind of prefix.
+Also, if CITATION-REGEXP is non-nil, don't fill header lines."
+  (interactive (progn
+                (barf-if-buffer-read-only)
+                (list (region-beginning) (region-end)
+                      (el:if current-prefix-arg 'full))))
+  (let ((fill-individual-varying-indent t))
+    (fill-individual-paragraphs min max justifyp citation-regexp)))
+
+(defun fill-individual-paragraphs (min max &optional justify citation-regexp)
+  "Fill paragraphs of uniform indentation within the region.
+This command divides the region into \"paragraphs\",
+treating every change in indentation level or prefix as a paragraph boundary,
+then fills each paragraph using its indentation level as the fill prefix.
+
+There is one special case where a change in indentation does not start
+a new paragraph.  This is for text of this form:
+
+   foo>    This line with extra indentation starts
+   foo> a paragraph that continues on more lines.
+
+These lines are filled together.
+
+When calling from a program, pass the range to fill
+as the first two arguments.
+
+Optional third and fourth arguments JUSTIFY and MAIL-FLAG:
+JUSTIFY to justify paragraphs (prefix arg),
+When filling a mail message, pass a regexp for CITATION-REGEXP
+which will match the prefix of a line which is a citation marker
+plus whitespace, but no other kind of prefix.
+Also, if CITATION-REGEXP is non-nil, don't fill header lines."
+  (interactive (progn
+                (barf-if-buffer-read-only)
+                (list (region-beginning) (region-end)
+                      (el:if current-prefix-arg 'full))))
+  (save-restriction
+    (save-excursion
+      (goto-char min)
+      (beginning-of-line)
+      (narrow-to-region (point) max)
+      (el:if citation-regexp
+         (while (and (not (eobp))
+                     (or (looking-at "[ \t]*[^ \t\n]+:")
+                         (looking-at "[ \t]*$")))
+           (el:if (looking-at "[ \t]*[^ \t\n]+:")
+               (search-forward "\n\n" nil 'move)
+             (forward-line 1))))
+      (narrow-to-region (point) max)
+      ;; Loop over paragraphs.
+      (while (progn
+              ;; Skip over all paragraph-separating lines
+              ;; so as to not include them in any paragraph.
+               (while (and (not (eobp))
+                          (progn (move-to-left-margin)
+                                 (and (not (eobp))
+                                      (looking-at paragraph-separate))))
+                 (forward-line 1))
+               (skip-chars-forward " \t\n") (not (eobp)))
+       (move-to-left-margin)
+       (let ((start (point))
+             fill-prefix fill-prefix-regexp)
+         ;; Find end of paragraph, and compute the smallest fill-prefix
+         ;; that fits all the lines in this paragraph.
+         (while (progn
+                  ;; Update the fill-prefix on the first line
+                  ;; and whenever the prefix good so far is too long.
+                  (el:if (not (and fill-prefix
+                                (looking-at fill-prefix-regexp)))
+                      (setq fill-prefix
+                            (fill-individual-paragraphs-prefix
+                             citation-regexp)
+                            fill-prefix-regexp (regexp-quote fill-prefix)))
+                  (forward-line 1)
+                  (el:if (bolp)
+                      ;; If forward-line went past a newline,
+                      ;; move further to the left margin.
+                      (move-to-left-margin))
+                  ;; Now stop the loop if end of paragraph.
+                  (and (not (eobp))
+                       (el:if fill-individual-varying-indent
+                           ;; If this line is a separator line, with or
+                           ;; without prefix, end the paragraph.
+                           (and
+                            (not (looking-at paragraph-separate))
+                            (save-excursion
+                              (not (and (looking-at fill-prefix-regexp)
+                                        (progn (forward-char
+                                                (length fill-prefix))
+                                               (looking-at
+                                                paragraph-separate))))))
+                         ;; If this line has more or less indent
+                         ;; than the fill prefix wants, end the paragraph.
+                         (and (looking-at fill-prefix-regexp)
+                              ;; If fill prefix is shorter than a new
+                              ;; fill prefix computed here, end paragraph.
+                              (let ((this-line-fill-prefix
+                                     (fill-individual-paragraphs-prefix
+                                      citation-regexp)))
+                                (>= (length fill-prefix)
+                                    (length this-line-fill-prefix)))
+                              (save-excursion
+                                (not (progn (forward-char
+                                             (length fill-prefix))
+                                            (or (looking-at "[ \t]")
+                                                (looking-at paragraph-separate)
+                                                (looking-at paragraph-start)))))
+                              (not (and (equal fill-prefix "")
+                                        citation-regexp
+                                        (looking-at citation-regexp))))))))
+         ;; Fill this paragraph, but don't add a newline at the end.
+         (let ((had-newline (bolp)))
+           (fill-region-as-paragraph start (point) justify)
+           (el:if (and (bolp) (not had-newline))
+               (delete-char -1))))))))
+(defun fill-individual-paragraphs-prefix (citation-regexp)
+  (let* ((adaptive-fill-first-line-regexp ".*")
+        (just-one-line-prefix
+         ;; Accept any prefix rather than just the ones matched by
+         ;; adaptive-fill-first-line-regexp.
+         (fill-context-prefix (point) (line-beginning-position 2)))
+        (two-lines-prefix
+         (fill-context-prefix (point) (line-beginning-position 3))))
+    (el:if (not just-one-line-prefix)
+       (buffer-substring
+        (point) (save-excursion (skip-chars-forward " \t") (point)))
+       ;; See if the citation part of JUST-ONE-LINE-PREFIX
+       ;; is the same as that of TWO-LINES-PREFIX,
+       ;; except perhaps with longer whitespace.
+      (el:if (and just-one-line-prefix two-lines-prefix
+              (let* ((one-line-citation-part
+                      (fill-individual-paragraphs-citation
+                       just-one-line-prefix citation-regexp))
+                     (two-lines-citation-part
+                      (fill-individual-paragraphs-citation
+                       two-lines-prefix citation-regexp))
+                     (adjusted-two-lines-citation-part
+                      (substring two-lines-citation-part 0
+                                 (string-match "[ \t]*\\'"
+                                               two-lines-citation-part))))
+                (and
+                (string-match (concat "\\`"
+                                      (regexp-quote
+                                       adjusted-two-lines-citation-part)
+                                      "[ \t]*\\'")
+                              one-line-citation-part)
+                (>= (string-width one-line-citation-part)
+                     (string-width two-lines-citation-part)))))
+           two-lines-prefix
+       just-one-line-prefix))))
+
+(defun fill-individual-paragraphs-citation (string citation-regexp)
+  (el:if citation-regexp
+      (el:if (string-match citation-regexp string)
+         (match-string 0 string)
+       "")
+    string))
+
+;; arch-tag: 727ad455-1161-4fa9-8df5-0f74b179216d
+;;; fill.el ends here
similarity index 100%
rename from text-mode.lisp
rename to src/textmodes/text-mode.lisp
similarity index 92%
rename from textprop.lisp
rename to src/textprop.lisp
index a73f19e..a558d25 100644 (file)
@@ -12,32 +12,31 @@ This also inhibits the use of the `intangible' text property.")
 ;;   if (EQ (*begin, *end) && begin != end)
 ;;     return NULL_INTERVAL;
     (when (> begin end)
-    ;; MOVITZ doesn't have psetf
-    (let ((tmp begin))
-      (setf begin end
-           end tmp))
-;;       (psetf begin end
-;;          end begin)
-      )
-    (if (typep object 'buffer)
-       (progn
-         (when (not (and (<= (buffer-min object) begin)
-                         (<= begin end)
-                         (<= end (buffer-max object))))
-           (signal 'args-out-of-range))
-         (setf i (intervals object))
-         (when (= (buffer-min object) (buffer-max object))
-           (return-from validate-interval-range (values nil begin end)))
-         (setf searchpos begin))
-      (let ((len (length (pstring-data object))))
-       (when (not (and (<= 0 begin)
-                       (<= begin end)
-                       (<= end len)))
-         (signal 'args-out-of-range))
-       (setf i (intervals object))
-       (when (zerop len)
-         (return-from validate-interval-range (values nil begin end)))
-       (setf searchpos begin)))
+      (psetf begin end
+            end begin))
+    (etypecase object
+        (buffer
+         (when (not (and (<= (buffer-min object) begin)
+                         (<= begin end)
+                         (<= end (buffer-max object))))
+           (signal 'args-out-of-range))
+         (setf i (intervals object))
+         (when (= (buffer-min object) (buffer-max object))
+           (return-from validate-interval-range (values nil begin end)))
+         (setf searchpos begin))
+      (pstring
+       (let ((len (length (pstring-data object))))
+         (when (not (and (<= 0 begin)
+                         (<= begin end)
+                         (<= end len)))
+           (signal 'args-out-of-range))
+         (setf i (intervals object))
+         (when (zerop len)
+           (return-from validate-interval-range (values nil begin end)))
+         (setf searchpos begin)))
+      (string
+       (return-from validate-interval-range
+         (values nil (max 0 begin) (min (length object) end)))))
     (if i
        (values (find-interval i searchpos) begin end)
       (if force
@@ -516,5 +515,16 @@ BUFFER can be either a buffer or nil (meaning current buffer)."
        'after)
        (t 
        'before)))))
+
+(defun remove-list-of-text-properties (start end list-of-properties &optional object)
+  "Remove some properties from text from START to END.
+The third argument LIST-OF-PROPERTIES is a list of property names to remove.
+If the optional fourth argument OBJECT is a buffer (or nil, which means
+the current buffer), START and END are buffer positions (integers or
+markers).  If OBJECT is a string, START and END are 0-based indices into it.
+Return t if any property was actually removed, nil otherwise."
+  (declare (ignore start and list-of-properties object))
+  (error "unimplemented"))
+
           
 (provide :lice-0.1/textprop)
similarity index 96%
rename from tty-render.lisp
rename to src/tty-render.lisp
index f7f6e0f..c7c18bb 100644 (file)
@@ -48,7 +48,7 @@ hardware.")
 (defun clear-to-eol (y start window frame)
   (declare (type window window)
           (type fixnum y start))
-  (clear-line-between window y start (1- (window-width window)) frame)
+  (clear-line-between window y start (1- (window-width window nil)) frame)
   ;; draw the seperator
   (when (window-seperator window)
     (putch #\| (+ (window-x window) (1- (window-width window t))) y window frame)))
@@ -97,12 +97,12 @@ the text properties present."
     ;; Special case: when the buffer is empty
     (if (= (buffer-size (window-buffer w)) 0)
        (progn 
-         (dotimes (y (window-height w))
+         (dotimes (y (window-height w nil))
            (clear-to-eol y 0 w frame))
          (setf cursor-x 0
                cursor-y 0))
       (let ((end (loop named row
-                      for y below (window-height w)
+                      for y below (window-height w nil)
                       for line from (window-top-line w) below cache-size
                       ;; return the last line, so we can erase the rest
                       finally (return-from row y)
@@ -115,7 +115,7 @@ the text properties present."
                            ;; setup the display properties.
                            (turn-on-attributes (window-buffer w) bp)
                            (loop named col
-                               for x below (window-width w) do
+                               for x below (window-width w nil) do
                                (progn
                                  ;; Skip the gap
                                  (when (= p (buffer-gap-start buf))
@@ -144,8 +144,8 @@ the text properties present."
                                    (incf p)
                                    (incf bp))))))))
        ;; Check if the bottom of the window needs to be erased.
-       (when (< end (1- (window-height w)))
-         (loop for i from end below (window-height w) do
+       (when (< end (1- (window-height w nil)))
+         (loop for i from end below (window-height w nil) do
                (clear-to-eol i 0 w frame)))))
     ;; rxvt draws black on black if i don't turn on a color
     (cl-ncurses::attroff (cl-ncurses::COLOR-PAIR 1))
@@ -155,13 +155,13 @@ the text properties present."
       (update-mode-line (window-buffer w))
       ;;(cl-ncurses::attron cl-ncurses::A_REVERSE)
       (cl-ncurses::attron (cl-ncurses::COLOR-PAIR 2))
-      (putstr (truncate-mode-line (window-buffer w) (window-width w))
+      (putstr (truncate-mode-line (window-buffer w) (window-width w nil))
              0 (window-height w nil) w frame)
       (cl-ncurses::attroff (cl-ncurses::COLOR-PAIR 2))
       ;;(cl-ncurses::attroff cl-ncurses::A_REVERSE)
       ;; don't forget the seperator on the modeline line
       (when (window-seperator w)
-       (putch #\| (+ (window-x w) (window-width w)) (window-height w) w frame)))
+       (putch #\| (+ (window-x w) (window-width w nil)) (window-height w nil) w frame)))
     (reset-line-state w)
     ;; Set the cursor at the right spot
     (values cursor-x cursor-y)))
similarity index 100%
rename from undo.lisp
rename to src/undo.lisp
similarity index 96%
rename from window.lisp
rename to src/window.lisp
index 500621f..15c25e4 100644 (file)
@@ -87,7 +87,7 @@ TYPE isn't used yet. it's just there for hype."
 \f
 ;;; Other non-display related functions
 
-(defun window-height (w &optional include-mode-line)
+(defun window-height (&optional (w (selected-window)) (include-mode-line t))
   "Return the height of the window. By default, the mode-line is not
 included in the height."
   ;; if the mode-line is nil, then there is no modeline.
@@ -96,7 +96,7 @@ included in the height."
       (slot-value w 'h)
     (1- (slot-value w 'h))))
 
-(defun window-width (w &optional include-seperator)
+(defun window-width (&optional (w (selected-window)) (include-seperator t))
   "Return the width of the window. By default, the vertical seperator,
 for horizontal splits, is not included in the width."
   ;; if the mode-line is nil, then there is no modeline.
@@ -379,9 +379,9 @@ starting line."
   "Fill in window's line cache from WINDOW-TOP with a full window's
 worth of lines and return T if POINT was in the line cache. otherwise
 don't change anything and return nil."
-  (let* ((lines (generate-n-lines-forward (window-buffer window) (window-width window)
+  (let* ((lines (generate-n-lines-forward (window-buffer window) (window-width window nil)
                                          (marker-position (window-top window))
-                                         (window-height window))))
+                                         (window-height window nil))))
     (add-end-of-buffer (window-buffer window) lines)
     (when (or always-return-lines
              (point-in-line-cache lines point))
@@ -391,9 +391,9 @@ don't change anything and return nil."
   "Fill in window's line cache from WINDOW-BOTTOM with a full window's
 worth of lines and return T if POINT was in the line cache. otherwise
 don't change anything and return nil."
-  (let* ((lines (generate-n-lines-backward (window-buffer window) (window-width window)
+  (let* ((lines (generate-n-lines-backward (window-buffer window) (window-width window nil)
                                           (marker-position (window-bottom window))
-                                          (window-height window))))
+                                          (window-height window nil))))
     (add-end-of-buffer (window-buffer window) lines)
     (when (or always-return-lines
              (point-in-line-cache lines point))
@@ -406,12 +406,12 @@ above WINDOW-POINT, or as many as possible if we hit the top of the window."
   (let* ((max (1- (buffer-size (window-buffer window))))
         (b (buffer-scan-newline (window-buffer window) point 0 0))
         (e (buffer-scan-newline (window-buffer window) point max 1))
-        (lines-above (generate-n-lines-backward (window-buffer window) (window-width window)
+        (lines-above (generate-n-lines-backward (window-buffer window) (window-width window nil)
                                                 e n-many))
         (lines-below (when (< e max)
-                       (generate-n-lines-forward (window-buffer window) (window-width window)
+                       (generate-n-lines-forward (window-buffer window) (window-width window nil)
                                                  (1+ e)
-                                                 (- (window-height window)
+                                                 (- (window-height window nil)
                                                     (min n-many 
                                                          (length lines-above)))))))
     (declare (ignore b))
@@ -441,21 +441,21 @@ above WINDOW-POINT, or as many as possible if we hit the top of the window."
     ;; set the top marker
     (setf (window-bottom-valid window) nil)
     (cond (bot
-          (let* ((tl (max 0 (- (length lines) (window-height window))))
-                 (bl (min (1- (length lines)) (+ tl (1- (window-height window))))))
+          (let* ((tl (max 0 (- (length lines) (window-height window nil))))
+                 (bl (min (1- (length lines)) (+ tl (1- (window-height window nil))))))
             (setf (marker-position (window-top window)) 
                   (cache-item-start (elt lines tl))
                   (window-top-line window) tl
                   (marker-position (window-bottom window)) (cache-item-end (elt lines bl)))))
          (top
           (let* ((tl (point-in-line-cache lines (marker-position (window-top window))))
-                 (bl (min (1- (length lines)) (+ tl (1- (window-height window))))))
+                 (bl (min (1- (length lines)) (+ tl (1- (window-height window nil))))))
             (setf (window-top-line window) tl
                   (marker-position (window-bottom window)) (cache-item-end (elt lines bl)))))
          (around
           (let* ((pl (point-in-line-cache lines point))
                  (tl (max 0 (- pl n-many)))
-                 (bl (min (1- (length lines)) (+ tl (1- (window-height window))))))
+                 (bl (min (1- (length lines)) (+ tl (1- (window-height window nil))))))
             (setf (marker-position (window-top window))
                   (cache-item-start (elt lines tl))
                   (window-top-line window) tl
@@ -586,8 +586,8 @@ If FRAME is a frame, search only that frame."
 (defun window-scroll-up (window n-lines)
   "scroll the window up (go torwards the end of the buffer) LINES many
 lines, moving the window point to be visible."
-  (let* ((len (+ (window-height window) n-lines))
-        (lines (generate-n-lines-forward (window-buffer window) (window-width window)
+  (let* ((len (+ (window-height window nil) n-lines))
+        (lines (generate-n-lines-forward (window-buffer window) (window-width window nil)
                                         (marker-position (window-top window)) 
                                         len)))
     ;; if there aren't n-lines left in the buffer then signal
@@ -606,13 +606,13 @@ lines, moving the window point to be visible."
 (defun window-scroll-down (window n-lines)
   "scroll the window down (go torwards the beginning of the buffer)
 LINES many lines, moving the window point to be visible."
-  (let* ((len (+ (window-height window) n-lines))
+  (let* ((len (+ (window-height window nil) n-lines))
         ;; FIXME: this is basically, gross.
-        (above (generate-n-lines-backward (window-buffer window) (window-width window)
+        (above (generate-n-lines-backward (window-buffer window) (window-width window nil)
                                           (max (buffer-min (window-buffer window))
                                                (1- (marker-position (window-top window))))
                                           n-lines))
-        (lines (generate-n-lines-forward (window-buffer window) (window-width window)
+        (lines (generate-n-lines-forward (window-buffer window) (window-width window nil)
                                          (cache-item-start 
                                           (elt above (max 0 (- (length above) n-lines))))
                                          len)))
@@ -624,7 +624,7 @@ LINES many lines, moving the window point to be visible."
     ;; FIXME: for now, set the point at the bottom of the window if it
     ;; isn't visible.
     (let ((eow (elt lines (1- (min (length lines)
-                                  (window-height window))))))
+                                  (window-height window nil))))))
       (when (or (> (window-point window) (cache-item-end eow))
                (not (point-in-line-cache lines (window-point window))))
        (set-window-point window (cache-item-start eow))))))
@@ -963,4 +963,17 @@ of `display-buffer' for additional customization information.
                 (other-buffer (current-buffer))))
   (select-window (display-buffer buffer other-window)))
 
+(defun set-window-start (window pos &optional noforce)
+  "Make display in WINDOW start at position POS in WINDOW's buffer.
+Return POS.
+Optional third arg NOFORCE non-nil inhibits next redisplay
+from overriding motion of point in order to display at this exact start."
+  )
+
+(defun window-start (&optional (window (selected-window)))
+  "Return position at which display currently starts in WINDOW.
+WINDOW defaults to the selected window.
+This is updated by redisplay or by calling `set-window-start'."
+  (marker-position (window-top window)))
+
 (provide :lice-0.1/window)
similarity index 100%
rename from wm.lisp
rename to src/wm.lisp
similarity index 100%
rename from wrappers.lisp
rename to src/wrappers.lisp