From d82f7434e47b3afeeefc44a22db38d27e8d67ffb Mon Sep 17 00:00:00 2001 From: tailor Date: Thu, 10 May 2007 14:45:58 +0000 Subject: [PATCH] [lice @ big huge rearrange. add hanoi. fix extended-command prefix bug.] --- configure.ac | 2 +- lice.asd | 53 - src/Makefile.in | 19 + all.lisp => src/all.lisp | 0 buffer-local.lisp => src/buffer-local.lisp | 0 buffer.lisp => src/buffer.lisp | 20 +- casefiddle.lisp => src/casefiddle.lisp | 0 src/charset.lisp | 67 ++ clisp-render.lisp => src/clisp-render.lisp | 16 +- clisp.lisp => src/clisp.lisp | 0 cmds.lisp => src/cmds.lisp | 0 commands.lisp => src/commands.lisp | 0 custom.lisp => src/custom.lisp | 0 data-types.lisp => src/data-types.lisp | 2 +- debug.lisp => src/debug.lisp | 0 debugger.lisp => src/debugger.lisp | 12 + editfns.lisp => src/editfns.lisp | 92 +- edmacro.lisp => src/edmacro.lisp | 0 src/elisp.lisp | 15 + files.lisp => src/files.lisp | 0 frame.lisp => src/frame.lisp | 0 global.lisp => src/global.lisp | 44 + help.lisp => src/help.lisp | 0 indent.lisp => src/indent.lisp | 48 +- insdel.lisp => src/insdel.lisp | 0 intervals.lisp => src/intervals.lisp | 0 keyboard.lisp => src/keyboard.lisp | 52 +- keymap.lisp => src/keymap.lisp | 0 src/lice.asd | 63 + lisp-indent.lisp => src/lisp/lisp-indent.lisp | 0 lisp-mode.lisp => src/lisp/lisp-mode.lisp | 0 paragraphs.lisp => src/lisp/paragraphs.lisp | 0 simple.lisp => src/lisp/simple.lisp | 122 +- subr.lisp => src/lisp/subr.lisp | 51 +- load.lisp => src/load.lisp | 0 main.lisp => src/main.lisp | 0 major-mode.lisp => src/major-mode.lisp | 0 make-image.lisp => src/make-image.lisp | 0 mcl-load.lisp => src/mcl-load.lisp | 0 mcl-render.lisp => src/mcl-render.lisp | 16 +- minibuffer.lisp => src/minibuffer.lisp | 0 movitz-render.lisp => src/movitz-render.lisp | 16 +- package.lisp => src/package.lisp | 0 src/play/dissociate.lisp | 105 ++ doctor.lisp => src/play/doctor.lisp | 0 src/play/hanoi.lisp | 448 ++++++++ recursive-edit.lisp => src/recursive-edit.lisp | 0 render.lisp => src/render.lisp | 2 +- search.lisp => src/search.lisp | 34 + subprocesses.lisp => src/subprocesses.lisp | 0 syntax.lisp => src/syntax.lisp | 0 src/textmodes/fill.lisp | 1461 ++++++++++++++++++++++++ text-mode.lisp => src/textmodes/text-mode.lisp | 0 textprop.lisp => src/textprop.lisp | 62 +- tty-render.lisp => src/tty-render.lisp | 16 +- undo.lisp => src/undo.lisp | 0 window.lisp => src/window.lisp | 51 +- wm.lisp => src/wm.lisp | 0 wrappers.lisp => src/wrappers.lisp | 0 59 files changed, 2718 insertions(+), 171 deletions(-) delete mode 100644 lice.asd create mode 100644 src/Makefile.in rename all.lisp => src/all.lisp (100%) rename buffer-local.lisp => src/buffer-local.lisp (100%) rename buffer.lisp => src/buffer.lisp (97%) rename casefiddle.lisp => src/casefiddle.lisp (100%) create mode 100644 src/charset.lisp rename clisp-render.lisp => src/clisp-render.lisp (94%) rename clisp.lisp => src/clisp.lisp (100%) rename cmds.lisp => src/cmds.lisp (100%) rename commands.lisp => src/commands.lisp (100%) rename custom.lisp => src/custom.lisp (100%) rename data-types.lisp => src/data-types.lisp (99%) rename debug.lisp => src/debug.lisp (100%) rename debugger.lisp => src/debugger.lisp (76%) rename editfns.lisp => src/editfns.lisp (87%) rename edmacro.lisp => src/edmacro.lisp (100%) create mode 100644 src/elisp.lisp rename files.lisp => src/files.lisp (100%) rename frame.lisp => src/frame.lisp (100%) rename global.lisp => src/global.lisp (85%) rename help.lisp => src/help.lisp (100%) rename indent.lisp => src/indent.lisp (86%) rename insdel.lisp => src/insdel.lisp (100%) rename intervals.lisp => src/intervals.lisp (100%) rename keyboard.lisp => src/keyboard.lisp (83%) rename keymap.lisp => src/keymap.lisp (100%) create mode 100644 src/lice.asd rename lisp-indent.lisp => src/lisp/lisp-indent.lisp (100%) rename lisp-mode.lisp => src/lisp/lisp-mode.lisp (100%) rename paragraphs.lisp => src/lisp/paragraphs.lisp (100%) rename simple.lisp => src/lisp/simple.lisp (94%) rename subr.lisp => src/lisp/subr.lisp (81%) rename load.lisp => src/load.lisp (100%) rename main.lisp => src/main.lisp (100%) rename major-mode.lisp => src/major-mode.lisp (100%) rename make-image.lisp => src/make-image.lisp (100%) rename mcl-load.lisp => src/mcl-load.lisp (100%) rename mcl-render.lisp => src/mcl-render.lisp (96%) rename minibuffer.lisp => src/minibuffer.lisp (100%) rename movitz-render.lisp => src/movitz-render.lisp (95%) rename package.lisp => src/package.lisp (100%) create mode 100644 src/play/dissociate.lisp rename doctor.lisp => src/play/doctor.lisp (100%) create mode 100644 src/play/hanoi.lisp rename recursive-edit.lisp => src/recursive-edit.lisp (100%) rename render.lisp => src/render.lisp (97%) rename search.lisp => src/search.lisp (92%) rename subprocesses.lisp => src/subprocesses.lisp (100%) rename syntax.lisp => src/syntax.lisp (100%) create mode 100644 src/textmodes/fill.lisp rename text-mode.lisp => src/textmodes/text-mode.lisp (100%) rename textprop.lisp => src/textprop.lisp (92%) rename tty-render.lisp => src/tty-render.lisp (96%) rename undo.lisp => src/undo.lisp (100%) rename window.lisp => src/window.lisp (96%) rename wm.lisp => src/wm.lisp (100%) rename wrappers.lisp => src/wrappers.lisp (100%) diff --git a/configure.ac b/configure.ac index ece9585..50ec594 100644 --- a/configure.ac +++ b/configure.ac @@ -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 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 index 0000000..d924b72 --- /dev/null +++ b/src/Makefile.in @@ -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 diff --git a/all.lisp b/src/all.lisp similarity index 100% rename from all.lisp rename to src/all.lisp diff --git a/buffer-local.lisp b/src/buffer-local.lisp similarity index 100% rename from buffer-local.lisp rename to src/buffer-local.lisp diff --git a/buffer.lisp b/src/buffer.lisp similarity index 97% rename from buffer.lisp rename to src/buffer.lisp index 9cf5896..1a4021e 100644 --- a/buffer.lisp +++ b/src/buffer.lisp @@ -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. diff --git a/casefiddle.lisp b/src/casefiddle.lisp 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 index 0000000..8567701 --- /dev/null +++ b/src/charset.lisp @@ -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")) + + + diff --git a/clisp-render.lisp b/src/clisp-render.lisp similarity index 94% rename from clisp-render.lisp rename to src/clisp-render.lisp index aaa1db5..3426969 100644 --- a/clisp-render.lisp +++ b/src/clisp-render.lisp @@ -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))) diff --git a/clisp.lisp b/src/clisp.lisp similarity index 100% rename from clisp.lisp rename to src/clisp.lisp diff --git a/cmds.lisp b/src/cmds.lisp similarity index 100% rename from cmds.lisp rename to src/cmds.lisp diff --git a/commands.lisp b/src/commands.lisp similarity index 100% rename from commands.lisp rename to src/commands.lisp diff --git a/custom.lisp b/src/custom.lisp similarity index 100% rename from custom.lisp rename to src/custom.lisp diff --git a/data-types.lisp b/src/data-types.lisp similarity index 99% rename from data-types.lisp rename to src/data-types.lisp index 6eb982f..7a8a5a2 100644 --- a/data-types.lisp +++ b/src/data-types.lisp @@ -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.") diff --git a/debug.lisp b/src/debug.lisp similarity index 100% rename from debug.lisp rename to src/debug.lisp diff --git a/debugger.lisp b/src/debugger.lisp similarity index 76% rename from debugger.lisp rename to src/debugger.lisp index 548a942..9bf7562 100644 --- a/debugger.lisp +++ b/src/debugger.lisp @@ -45,3 +45,15 @@ (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*))) diff --git a/editfns.lisp b/src/editfns.lisp similarity index 87% rename from editfns.lisp rename to src/editfns.lisp index 984b3b6..166234b 100644 --- a/editfns.lisp +++ b/src/editfns.lisp @@ -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) diff --git a/edmacro.lisp b/src/edmacro.lisp 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 index 0000000..9ead271 --- /dev/null +++ b/src/elisp.lisp @@ -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))) + diff --git a/files.lisp b/src/files.lisp similarity index 100% rename from files.lisp rename to src/files.lisp diff --git a/frame.lisp b/src/frame.lisp similarity index 100% rename from frame.lisp rename to src/frame.lisp diff --git a/global.lisp b/src/global.lisp similarity index 85% rename from global.lisp rename to src/global.lisp index 804ef73..3710141 100644 --- a/global.lisp +++ b/src/global.lisp @@ -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) diff --git a/help.lisp b/src/help.lisp similarity index 100% rename from help.lisp rename to src/help.lisp diff --git a/indent.lisp b/src/indent.lisp similarity index 86% rename from indent.lisp rename to src/indent.lisp index 6917471..5e16867 100644 --- a/indent.lisp +++ b/src/indent.lisp @@ -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"))) diff --git a/insdel.lisp b/src/insdel.lisp similarity index 100% rename from insdel.lisp rename to src/insdel.lisp diff --git a/intervals.lisp b/src/intervals.lisp similarity index 100% rename from intervals.lisp rename to src/intervals.lisp diff --git a/keyboard.lisp b/src/keyboard.lisp similarity index 83% rename from keyboard.lisp rename to src/keyboard.lisp index f540aec..ae6d0ee 100644 --- a/keyboard.lisp +++ b/src/keyboard.lisp @@ -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 () diff --git a/keymap.lisp b/src/keymap.lisp 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 index 0000000..4399cb9 --- /dev/null +++ b/src/lice.asd @@ -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"|#)))))) diff --git a/lisp-indent.lisp b/src/lisp/lisp-indent.lisp similarity index 100% rename from lisp-indent.lisp rename to src/lisp/lisp-indent.lisp diff --git a/lisp-mode.lisp b/src/lisp/lisp-mode.lisp similarity index 100% rename from lisp-mode.lisp rename to src/lisp/lisp-mode.lisp diff --git a/paragraphs.lisp b/src/lisp/paragraphs.lisp similarity index 100% rename from paragraphs.lisp rename to src/lisp/paragraphs.lisp diff --git a/simple.lisp b/src/lisp/simple.lisp similarity index 94% rename from simple.lisp rename to src/lisp/simple.lisp index 158a8f0..f565ebb 100644 --- a/simple.lisp +++ b/src/lisp/simple.lisp @@ -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))) + ;;; (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))) + ;; 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) diff --git a/subr.lisp b/src/lisp/subr.lisp similarity index 81% rename from subr.lisp rename to src/lisp/subr.lisp index 11cd8a7..04a099a 100644 --- a/subr.lisp +++ b/src/lisp/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)) + ) + + +;;; 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) diff --git a/load.lisp b/src/load.lisp similarity index 100% rename from load.lisp rename to src/load.lisp diff --git a/main.lisp b/src/main.lisp similarity index 100% rename from main.lisp rename to src/main.lisp diff --git a/major-mode.lisp b/src/major-mode.lisp similarity index 100% rename from major-mode.lisp rename to src/major-mode.lisp diff --git a/make-image.lisp b/src/make-image.lisp similarity index 100% rename from make-image.lisp rename to src/make-image.lisp diff --git a/mcl-load.lisp b/src/mcl-load.lisp similarity index 100% rename from mcl-load.lisp rename to src/mcl-load.lisp diff --git a/mcl-render.lisp b/src/mcl-render.lisp similarity index 96% rename from mcl-render.lisp rename to src/mcl-render.lisp index bf89177..1a68957 100644 --- a/mcl-render.lisp +++ b/src/mcl-render.lisp @@ -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))) diff --git a/minibuffer.lisp b/src/minibuffer.lisp similarity index 100% rename from minibuffer.lisp rename to src/minibuffer.lisp diff --git a/movitz-render.lisp b/src/movitz-render.lisp similarity index 95% rename from movitz-render.lisp rename to src/movitz-render.lisp index 3c25fac..9e598e3 100644 --- a/movitz-render.lisp +++ b/src/movitz-render.lisp @@ -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))) diff --git a/package.lisp b/src/package.lisp 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 index 0000000..bbdbb7a --- /dev/null +++ b/src/play/dissociate.lisp @@ -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 diff --git a/doctor.lisp b/src/play/doctor.lisp 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 index 0000000..b1de6b2 --- /dev/null +++ b/src/play/hanoi.lisp @@ -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 . + +;;; 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))) + + +;;; 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 diff --git a/recursive-edit.lisp b/src/recursive-edit.lisp similarity index 100% rename from recursive-edit.lisp rename to src/recursive-edit.lisp diff --git a/render.lisp b/src/render.lisp similarity index 97% rename from render.lisp rename to src/render.lisp index 3270c87..4c758dc 100644 --- a/render.lisp +++ b/src/render.lisp @@ -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 diff --git a/search.lisp b/src/search.lisp similarity index 92% rename from search.lisp rename to src/search.lisp index d1215c8..a4769f8 100644 --- a/search.lisp +++ b/src/search.lisp @@ -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. diff --git a/subprocesses.lisp b/src/subprocesses.lisp similarity index 100% rename from subprocesses.lisp rename to src/subprocesses.lisp diff --git a/syntax.lisp b/src/syntax.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 index 0000000..4381cd8 --- /dev/null +++ b/src/textmodes/fill.lisp @@ -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]*\\([-!|#%;>*,A7$,1s"s#sC$,2"F(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]*[])},A;,b;(B?!;:-]") + (save-excursion + (skip-chars-backward " \t") + (unless (bolp) + (backward-char 1) + (or (looking-at "[([{,A+,b+(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)) + + +(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))))) + + +(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 diff --git a/text-mode.lisp b/src/textmodes/text-mode.lisp similarity index 100% rename from text-mode.lisp rename to src/textmodes/text-mode.lisp diff --git a/textprop.lisp b/src/textprop.lisp similarity index 92% rename from textprop.lisp rename to src/textprop.lisp index a73f19e..a558d25 100644 --- a/textprop.lisp +++ b/src/textprop.lisp @@ -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) diff --git a/tty-render.lisp b/src/tty-render.lisp similarity index 96% rename from tty-render.lisp rename to src/tty-render.lisp index f7f6e0f..c7c18bb 100644 --- a/tty-render.lisp +++ b/src/tty-render.lisp @@ -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))) diff --git a/undo.lisp b/src/undo.lisp similarity index 100% rename from undo.lisp rename to src/undo.lisp diff --git a/window.lisp b/src/window.lisp similarity index 96% rename from window.lisp rename to src/window.lisp index 500621f..15c25e4 100644 --- a/window.lisp +++ b/src/window.lisp @@ -87,7 +87,7 @@ TYPE isn't used yet. it's just there for hype." ;;; 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) diff --git a/wm.lisp b/src/wm.lisp similarity index 100% rename from wm.lisp rename to src/wm.lisp diff --git a/wrappers.lisp b/src/wrappers.lisp similarity index 100% rename from wrappers.lisp rename to src/wrappers.lisp -- 2.11.4.GIT