- phemlock-cvs@common-lisp.net - mailman3.common-lisp.net

[Phemlock-cvs] CVS update: phemlock/src/core/charmacs.lisp
by crhodes＠common-lisp.net 02 Jun '05

02 Jun '05

Update of /project/phemlock/cvsroot/phemlock/src/core In directory common-lisp.net:/tmp/cvs-serv1415/src/core Modified Files: charmacs.lisp Log Message: Minor patches to make it build and run with current mcclim. Date: Thu Jun 2 13:52:05 2005 Author: crhodes Index: phemlock/src/core/charmacs.lisp diff -u phemlock/src/core/charmacs.lisp:1.2 phemlock/src/core/charmacs.lisp:1.3 --- phemlock/src/core/charmacs.lisp:1.2 Mon Dec 27 19:53:27 2004 +++ phemlock/src/core/charmacs.lisp Thu Jun 2 13:52:05 2005 @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; #+CMU (ext:file-comment - "$Header: /project/phemlock/cvsroot/phemlock/src/core/charmacs.lisp,v 1.2 2004/12/27 18:53:27 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/charmacs.lisp,v 1.3 2005/06/02 11:52:05 crhodes Exp $") ;;; ;;; ********************************************************************** ;;; @@ -29,7 +29,7 @@ ;;;; Stuff for the Syntax table functions (syntax) -(defconstant syntax-char-code-limit char-code-limit +(defconstant syntax-char-code-limit 256 "The highest char-code which a character argument to the syntax table functions may have.")

1 0

[Phemlock-cvs] CVS update: phemlock/src/clim/patch.lisp
by crhodes＠common-lisp.net 02 Jun '05

02 Jun '05

Update of /project/phemlock/cvsroot/phemlock/src/clim In directory common-lisp.net:/tmp/cvs-serv1415/src/clim Modified Files: patch.lisp Log Message: Minor patches to make it build and run with current mcclim. Date: Thu Jun 2 13:52:04 2005 Author: crhodes Index: phemlock/src/clim/patch.lisp diff -u phemlock/src/clim/patch.lisp:1.1.1.1 phemlock/src/clim/patch.lisp:1.2 --- phemlock/src/clim/patch.lisp:1.1.1.1 Fri Jul 9 15:38:05 2004 +++ phemlock/src/clim/patch.lisp Thu Jun 2 13:52:04 2005 @@ -1,13 +1,5 @@ (in-package :clim-internals) -(defmethod stream-listen ((stream standard-extended-input-stream)) - (with-encapsulating-stream (estream stream) - (loop for char = (read-gesture-or-reason stream :timeout 0 :peek-p t) - do (if (read-result-p char) - (loop-finish) - (stream-read-gesture estream)) ; consume pointer gesture - finally (return (characterp char))))) - (in-package :clim-clx) #+NIL

1 0

[Phemlock-cvs] CVS update: phemlock/hemlock.asd
by crhodes＠common-lisp.net 02 Jun '05

02 Jun '05

Update of /project/phemlock/cvsroot/phemlock In directory common-lisp.net:/tmp/cvs-serv1415 Modified Files: hemlock.asd Log Message: Minor patches to make it build and run with current mcclim. Date: Thu Jun 2 13:52:04 2005 Author: crhodes Index: phemlock/hemlock.asd diff -u phemlock/hemlock.asd:1.7 phemlock/hemlock.asd:1.8 --- phemlock/hemlock.asd:1.7 Sun Jan 30 15:51:33 2005 +++ phemlock/hemlock.asd Thu Jun 2 13:52:04 2005 @@ -64,6 +64,7 @@ :directory (pathname-directory *hemlock-base-directory*) :defaults *hemlock-base-directory*) + :depends-on (clx mcclim) ;; :source-extension "lisp" ;; :binary-pathname #.*binary-pathname* ;; :depends-on (:clim-clx #+NIL :mcclim-freetype) @@ -105,14 +106,14 @@ ((:file "package") ;; Lisp implementation specific stuff goes into one of the next ;; two files. - (:file "lispdep") - (:file "hemlock-ext") + (:file "lispdep" :depends-on ("package")) + (:file "hemlock-ext" :depends-on ("package")) - (:file "decls") ; early declarations of functions and stuff - (:file "struct") - #+port-core-struct-ed (:file "struct-ed") - (hemlock-system:iso-8859-1-file "charmacs") - (:file "key-event"))) + (:file "decls" :depends-on ("package")) ; early declarations of functions and stuff + (:file "struct" :depends-on ("package")) + #+port-core-struct-ed (:file "struct-ed" :depends-on ("package")) + (hemlock-system:iso-8859-1-file "charmacs" :depends-on ("package")) + (:file "key-event" :depends-on ("package")))) (:module bitmap-1 :pathname #.(merge-pathnames (make-pathname @@ -128,7 +129,7 @@ (make-pathname :directory '(:relative "src" "core")) *hemlock-base-directory*) - :depends-on (bitmap-1) + :depends-on (bitmap-1 core-1) :components ((:file "rompsite") (:file "input") @@ -168,7 +169,7 @@ (make-pathname :directory '(:relative "src")) *hemlock-base-directory*) - :depends-on (core-2) + :depends-on (core-2 core-1) :components ((:file "pop-up-stream"))) (:module tty-2 @@ -183,7 +184,7 @@ (make-pathname :directory '(:relative "src")) *hemlock-base-directory*) - :depends-on (root-1) + :depends-on (root-1 core-1) :components ((:file "font") (:file "streams") @@ -196,7 +197,7 @@ (make-pathname :directory '(:relative "src" "user")) *hemlock-base-directory*) - :depends-on (root-2) + :depends-on (root-2 core-1) :components ((:file "echocoms") @@ -258,7 +259,7 @@ (make-pathname :directory '(:relative "src" "bitmap")) *hemlock-base-directory*) - :depends-on (user-1) + :depends-on (user-1 core-1) :components ((:file "rompsite") (:file "input") @@ -270,7 +271,7 @@ (make-pathname :directory '(:relative "src" "clim")) *hemlock-base-directory*) - :depends-on (bitmap-2) + :depends-on (bitmap-2 core-1) :components ((:file "patch") (:file "foo")

1 0

[Phemlock-cvs] CVS update: phemlock/hemlock.asd
by crhodes＠common-lisp.net 30 Jan '05

30 Jan '05

Update of /project/phemlock/cvsroot/phemlock In directory common-lisp.net:/tmp/cvs-serv6898 Modified Files: hemlock.asd Log Message: Make hemlock compile under sbcl running in any locale. Date: Sun Jan 30 06:51:35 2005 Author: crhodes Index: phemlock/hemlock.asd diff -u phemlock/hemlock.asd:1.6 phemlock/hemlock.asd:1.7 --- phemlock/hemlock.asd:1.6 Mon Dec 27 10:53:14 2004 +++ phemlock/hemlock.asd Sun Jan 30 06:51:33 2005 @@ -4,10 +4,42 @@ (defpackage #:hemlock-system (:use #:cl) - (:export #:*hemlock-base-directory*)) + (:export #:*hemlock-base-directory* #:iso-8859-1-file)) (in-package #:hemlock-system) +(defclass iso-8859-1-file (asdf:cl-source-file) ()) +(defmethod asdf:perform ((o asdf:compile-op) (c iso-8859-1-file)) + ;; Darn. Can't just CALL-NEXT-METHOD; have to reimplement the + ;; world. + (let ((source-file (asdf:component-pathname c)) + (output-file (car (asdf:output-files o c)))) + (multiple-value-bind (output warnings-p failure-p) + (compile-file source-file :output-file output-file + #+sbcl #+sbcl :external-format :iso-8859-1) + (when warnings-p + (case (asdf:operation-on-warnings o) + (:warn (warn + "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>" + o c)) + (:error (error 'compile-warned :component c :operation o)) + (:ignore nil))) + (when failure-p + (case (asdf:operation-on-failure o) + (:warn (warn + "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>" + o c)) + (:error (error 'compile-failed :component c :operation o)) + (:ignore nil))) + (unless output + (error 'asdf:compile-error :component c :operation o))))) +(defmethod perform ((o asdf:load-source-op) (c iso-8859-1-file)) + ;; likewise, have to reimplement rather than closily extend + (let ((source (asdf:component-pathname c))) + (setf (asdf:component-property c 'asdf::last-loaded-as-source) + (and (load source #+sbcl #+sbcl :external-format :iso-8859-1) + (get-universal-time))))) + (pushnew :command-bits *features*) (pushnew :buffered-lines *features*) @@ -79,7 +111,7 @@ (:file "decls") ; early declarations of functions and stuff (:file "struct") #+port-core-struct-ed (:file "struct-ed") - (:file "charmacs") + (hemlock-system:iso-8859-1-file "charmacs") (:file "key-event"))) (:module bitmap-1 :pathname #.(merge-pathnames

1 0

[Phemlock-cvs] CVS update: phemlock/src/user/bindings-gb.lisp
by gbaumann＠common-lisp.net 27 Dec '04

27 Dec '04

Update of /project/phemlock/cvsroot/phemlock/src/user In directory common-lisp.net:/tmp/cvs-serv1172/src/user Modified Files: bindings-gb.lisp Log Message: half-way working undo Date: Mon Dec 27 19:53:40 2004 Author: gbaumann Index: phemlock/src/user/bindings-gb.lisp diff -u phemlock/src/user/bindings-gb.lisp:1.1.1.1 phemlock/src/user/bindings-gb.lisp:1.2 --- phemlock/src/user/bindings-gb.lisp:1.1.1.1 Fri Jul 9 15:38:49 2004 +++ phemlock/src/user/bindings-gb.lisp Mon Dec 27 19:53:35 2004 @@ -2,12 +2,16 @@ (bind-key "Scroll Window Down" #k"pagedown") (bind-key "Scroll Window Up" #k"pageup") -(bind-key "Undo" #k"control-\/") (bind-key "Help" #k"control-h") (bind-key "Dabbrev Expand" #k"meta-/") -(bind-key "just one space" #k"meta-space") +(bind-key "Just One Space" #k"meta-space") +(bind-key "Mark Form" #k"control-meta-space") +(bind-key "New Undo" #k"control-\/") + + + + -

1 0

[Phemlock-cvs] CVS update: phemlock/src/core/charmacs.lisp phemlock/src/core/htext3.lisp phemlock/src/core/htext4.lisp phemlock/src/core/macros.lisp
by gbaumann＠common-lisp.net 27 Dec '04

27 Dec '04

Update of /project/phemlock/cvsroot/phemlock/src/core In directory common-lisp.net:/tmp/cvs-serv1172/src/core Modified Files: charmacs.lisp htext3.lisp htext4.lisp macros.lisp Log Message: half-way working undo Date: Mon Dec 27 19:53:31 2004 Author: gbaumann Index: phemlock/src/core/charmacs.lisp diff -u phemlock/src/core/charmacs.lisp:1.1 phemlock/src/core/charmacs.lisp:1.2 --- phemlock/src/core/charmacs.lisp:1.1 Fri Jul 9 17:00:36 2004 +++ phemlock/src/core/charmacs.lisp Mon Dec 27 19:53:27 2004 @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; #+CMU (ext:file-comment - "$Header: /project/phemlock/cvsroot/phemlock/src/core/charmacs.lisp,v 1.1 2004/07/09 15:00:36 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/charmacs.lisp,v 1.2 2004/12/27 18:53:27 gbaumann Exp $") ;;; ;;; ********************************************************************** ;;; @@ -81,13 +81,26 @@ :lower, :upper, or :both, and var is bound to each character in order as specified under character relations in the manual. When :both is specified, lowercase letters are processed first." + ;; ### Hmm, I added iso-latin-1 characters here, but this gets eaten + ;; by the ALPHA-CHAR-P in ALPHA-CHARS-LOOP. --GB 2004-11-20 (case kind (:both - `(progn (alpha-chars-loop ,var #\a #\z nil ,forms) - (alpha-chars-loop ,var #\A #\Z ,result ,forms))) + `(progn + (alpha-chars-loop ,var #\a #\z nil ,forms) + (alpha-chars-loop ,var #\ß #\ö nil ,forms) + (alpha-chars-loop ,var #\ø #\ÿ nil ,forms) + (alpha-chars-loop ,var #\A #\Z nil ,forms) + (alpha-chars-loop ,var #\À #\Ö nil ,forms) + (alpha-chars-loop ,var #\Ø #\Þ ,result ,forms) )) (:lower - `(alpha-chars-loop ,var #\a #\z ,result ,forms)) + `(progn + (alpha-chars-loop ,var #\ß #\ö nil ,forms) + (alpha-chars-loop ,var #\ø #\ÿ nil ,forms) + (alpha-chars-loop ,var #\a #\z ,result ,forms) )) (:upper - `(alpha-chars-loop ,var #\A #\Z ,result ,forms)) + `(progn + (alpha-chars-loop ,var #\A #\Z nil ,forms) + (alpha-chars-loop ,var #\À #\Ö nil ,forms) + (alpha-chars-loop ,var #\Ø #\Þ ,result ,forms) )) (t (error "Kind argument not one of :lower, :upper, or :both -- ~S." kind)))) Index: phemlock/src/core/htext3.lisp diff -u phemlock/src/core/htext3.lisp:1.2 phemlock/src/core/htext3.lisp:1.3 --- phemlock/src/core/htext3.lisp:1.2 Fri Dec 24 00:58:28 2004 +++ phemlock/src/core/htext3.lisp Mon Dec 27 19:53:27 2004 @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; #+CMU (ext:file-comment - "$Header: /project/phemlock/cvsroot/phemlock/src/core/htext3.lisp,v 1.2 2004/12/23 23:58:28 abakic Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/htext3.lisp,v 1.3 2004/12/27 18:53:27 gbaumann Exp $") ;;; ;;; ********************************************************************** ;;; @@ -164,7 +164,7 @@ (+ last-charpos (- this-charpos charpos))))) (setf (line-next previous) new-line previous new-line)))))))) -(defun ninsert-region (mark region) +(defmethod ninsert-region (mark region) "Inserts the given Region at the Mark, possibly destroying the Region. Region may not be a part of any buffer's region." (let* ((start (region-start region)) Index: phemlock/src/core/htext4.lisp diff -u phemlock/src/core/htext4.lisp:1.2 phemlock/src/core/htext4.lisp:1.3 --- phemlock/src/core/htext4.lisp:1.2 Fri Dec 24 00:58:29 2004 +++ phemlock/src/core/htext4.lisp Mon Dec 27 19:53:27 2004 @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; #+CMU (ext:file-comment - "$Header: /project/phemlock/cvsroot/phemlock/src/core/htext4.lisp,v 1.2 2004/12/23 23:58:29 abakic Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/htext4.lisp,v 1.3 2004/12/27 18:53:27 gbaumann Exp $") ;;; ;;; ********************************************************************** ;;; @@ -64,7 +64,8 @@ (region-end *internal-temp-region*) mark) (setf (region-start *internal-temp-region*) mark (region-end *internal-temp-region*) other-mark)) - (delete-region *internal-temp-region*) t) + (delete-region *internal-temp-region*) + t) (t nil))))))) Index: phemlock/src/core/macros.lisp diff -u phemlock/src/core/macros.lisp:1.2 phemlock/src/core/macros.lisp:1.3 --- phemlock/src/core/macros.lisp:1.2 Sat Sep 4 01:06:51 2004 +++ phemlock/src/core/macros.lisp Mon Dec 27 19:53:27 2004 @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; #+CMU (ext:file-comment - "$Header: /project/phemlock/cvsroot/phemlock/src/core/macros.lisp,v 1.2 2004/09/03 23:06:51 abakic Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/macros.lisp,v 1.3 2004/12/27 18:53:27 gbaumann Exp $") ;;; ;;; ********************************************************************** ;;; @@ -541,6 +541,44 @@ displaying any current output after each line." (when (and (numberp height) (zerop height)) (editor-error "I doubt that you really want a window with no height")) + `(invoke-with-pop-up-display (lambda (,var) + ,@body) + ,buffer-name ,height)) + +(defun invoke-with-pop-up-display (cont buffer-name height) + (let ((cleanup-p nil) + (stream (get-random-typeout-info buffer-name height))) + (unwind-protect + (progn + (catch 'more-punt + (when height + ;; Test height since it may be supplied, but evaluate + ;; to nil. + (when height + (prepare-for-random-typeout stream height) + (setf cleanup-p t))) + (multiple-value-prog1 + (funcall cont stream) + (unless height + (prepare-for-random-typeout stream nil) + (setf cleanup-p t) + (device-random-typeout-full-more (device-hunk-device + (window-hunk + (random-typeout-stream-window stream))) + stream)) + (end-random-typeout stream))) + (setf cleanup-p nil)) + (when cleanup-p (random-typeout-cleanup stream))))) + +#|| +(defmacro with-pop-up-display ((var &key height (buffer-name "Random Typeout")) + &body body) + "Execute body in a context with var bound to a stream. Output to the stream + appears in the buffer named buffer-name. The pop-up display appears after + the body completes, but if you supply :height, the output is line buffered, + displaying any current output after each line." + (when (and (numberp height) (zerop height)) + (editor-error "I doubt that you really want a window with no height")) (let ((cleanup-p (gensym)) (stream (gensym))) `(let ((,cleanup-p nil) @@ -568,6 +606,7 @@ (end-random-typeout ,var)))) (setf ,cleanup-p nil)) (when ,cleanup-p (random-typeout-cleanup ,stream)))))) +||# (declaim (special *random-typeout-ml-fields* *buffer-names*))

1 0

[Phemlock-cvs] CVS update: phemlock/src/clim/foo.lisp
by gbaumann＠common-lisp.net 27 Dec '04

27 Dec '04

Update of /project/phemlock/cvsroot/phemlock/src/clim In directory common-lisp.net:/tmp/cvs-serv1172/src/clim Modified Files: foo.lisp Log Message: half-way working undo Date: Mon Dec 27 19:53:23 2004 Author: gbaumann Index: phemlock/src/clim/foo.lisp diff -u phemlock/src/clim/foo.lisp:1.5 phemlock/src/clim/foo.lisp:1.6 --- phemlock/src/clim/foo.lisp:1.5 Wed Dec 15 13:16:43 2004 +++ phemlock/src/clim/foo.lisp Mon Dec 27 19:53:20 2004 @@ -8,41 +8,99 @@ (in-package :clim-hemlock) -;;;; RANDOM NOTES +;;;; ------------------------------------------------------------------------------------------ +;;;; RANDOM NOTES +;;;; + +;; Hemlock has this funny notion of "hunks" which are just device-specific +;; descriptions of a (hemlock) window. A hunk then points to some real +;; window system window or somesuch. I really thing that these days thanks +;; to multiple inheritance we should conflate hunks, [hemlock] windows and +;; [window system] windows. This is not how that is currently done though, +;; as i am not 100% certain about the implications. ;; Perhaps Hemlock should function as a frame manager too, so that you can -;; embed say a listen into Hemlocks main application frame. Or goodies -;; written by third parties like a side bar. Event processing then becomes -;; tricky and keyboard events are about to under focus control and mouse -;; event are about to be under pointer control. And: CLIM won't cope with a -;; single application frame been displayed more than once like Emacs can -;; display a buffer more than once. But: This is perhaps even possible -;; thru' some glorious kludges. - -;; How exactly Hemlock can be integrated as the McCLIM line editor is still -;; an open question. Also: If Hemlock functions as a line editor or as a -;; text-field gadget, we surely want to operate in some restricted mode -;; where we can't switch buffers. And line editing buffers and text-field -;; buffers should be hidden. => Notion of a session. +;; embed say a lister pane into Hemlock's main application frame. Or +;; goodies written by third parties like a side bar. Event processing then +;; becomes tricky and keyboard events are about to be under focus control +;; and mouse events are about to be under pointer control. And: CLIM won't +;; cope with a single application frame been displayed more than once like +;; Emacs can display a buffer more than once. But: This is perhaps even +;; possible thru' some glorious kludges. + +;; INTEGRATION OF HEMLOCK AS A GADGET. When we want to have Hemlock as a +;; CLIM gadget as a substitute for the text-field gadget we need to tackle +;; the following problems: + +;; - CLIM has an event loop which just passes single events to +;; HANDLE-EVENT [in case of gadgets] and expects the event handler to +;; return after done with the event. But Hemlock really has a kind of +;; recursive event, where one event can trigger going down into another +;; event loop. The easiest solution to solve this, is to have two +;; threads, the CLIM thread and for each text-field gadget another +;; Hemlock process. + +;; - In a single line text entry field there really is no room for a +;; modeline or the echo buffer. The modeline isn't that important here, +;; but you'd still want to be able to enter stuff to the echo buffer. +;; The solution perhaps is an echo buffer, which pops up on demand and +;; is placed near the cursor and goes away after you are finished +;; providing some arguments. + +;; - When using Hemlock as a text-field gadget, you'd really want to avoid +;; creating windows or switching buffers. + +;; HEMLOCK AS THE LINE EDITOR. Not really much thought about that one yet +;; besides that all the restriction of above apply too. + +;; MULTIPLE HEMLOCKS. There is the question about how much state should be +;; shared between mutiple instances of Hemlock. ;; - DEVICE-HUNKS doesn't seem to be used anywhere beyond device ;; implementations. + ;; - DEVICE-BOTTOM-WINDOW-BASE seems to be only used from ;; tty-screen.lisp. -;;;; HEMLOCK AS GADGET +;;;; ------------------------------------------------------------------------------------------ +;;;; TODO / BUGS +;;;; + +;; - fix this random CLIM bug with :y-align in draw-text*. -;; - creating new windows can easily been forbidden by just making -;; DEVICE-MAKE-WINDOW fail. -;; - How can switching buffers be forbidden? - -(defclass clim-device (device) - (;; cursor - (cursor-hunk :initform nil - :documentation "The hunk that has the cursor.") - (windows :initform nil - ) - )) +;; - where is the modeline? +;; well, there now is a modeline, but it isn't up to date :( +;; also the echo area now has one. + +;; - new need a new composite pane. +;; Or we use a different strategy. + +;; - c-x 0, c-x 3, c-x 5. + +;; - c-up and c-down + +;; - something steals c-g + +;; - pop up streams. + +;; - BABA needs a real name. + +;; - can't we merge a hunk with its stream thanks to multiple inheritance? + +;; - we really need to get input working. I can't type umlauts and these +;; dead keys aren't working either. + +;;;; ------------------------------------------------------------------------------------------ + +(defparameter *gutter* 10 + "The gutter to place between between the matter in a hemlock pane and its + margin to improve legibility (sp?, damn i miss ispell).") + +(defclass clim-device (device) + ;; cursor + ((cursor-hunk + :initform nil :documentation "The hunk that has the cursor.") + (windows :initform nil) )) (defclass clim-hunk-pane (CLIM:APPLICATION-PANE) ((hunk) @@ -54,6 +112,7 @@ (defmethod device-exit ((device clim-device))) (defmethod device-smart-redisplay ((device clim-device) window) + ;; We aren't smart by any margin. (device-dumb-redisplay device window)) (defmethod device-after-redisplay ((device clim-device)) @@ -94,7 +153,7 @@ (defmethod device-next-window ((device clim-device) window) (with-slots (windows) device (elt windows (mod (1+ (position window windows)) - (length windows))))) + (length windows))))) (defmethod device-previous-window ((device clim-device) window) (with-slots (windows) device @@ -103,76 +162,66 @@ (defmethod device-delete-window ((device clim-device) window) (let* ((hunk (window-hunk window)) - (stream (clim-hunk-stream hunk)) - (parent (clim:sheet-parent stream))) + (stream (clim-hunk-stream hunk)) + (parent (clim:sheet-parent stream))) (clim:sheet-disown-child parent stream) (setf (slot-value device 'windows) - (remove window (slot-value device 'windows))) + (remove window (slot-value device 'windows))) (let ((buffer (window-buffer window))) - (setf (buffer-windows buffer) (delete window (buffer-windows buffer)))) - ) - ) + (setf (buffer-windows buffer) (delete window (buffer-windows buffer)))) ) ) + +(defclass clim-hunk-pane (CLIM:APPLICATION-PANE) + ((hunk) + )) (defmethod device-make-window ((device clim-device) start modelinep window font-family - ask-user x y width-arg height-arg proportion - &aux res) - (print (list start modelinep window font-family ask-user x y width-arg height-arg proportion) - *trace-output*) - (finish-output *trace-output*) + ask-user x y width-arg height-arg proportion + &aux res) (let* ((hunk (window-hunk *current-window*)) - (stream (clim-hunk-stream hunk)) - (parent (clim:sheet-parent stream))) - (print parent *trace-output*) - (print (clim:sheet-children parent) *trace-output*) - (clim:with-look-and-feel-realization ((clim:frame-manager clim:*application-frame*) - clim:*application-frame*) - (let ((new (clim:make-pane 'clim-hunk-pane - :incremental-redisplay t - :width 100 :height 200 #|:min-height 200|# :background clim:+white+))) - (let* ((window (hi::internal-make-window)) - (hunk (make-instance 'clim-hunk :stream new))) - (setf res window) - (baba-aux device window hunk *current-buffer*) - (let ((p (position *current-window* (slot-value device 'windows)))) - (setf (slot-value device 'windows) - (append (subseq (slot-value device 'windows) 0 p) - (list window) - (subseq (slot-value device 'windows) p)))) - ) - ;; since we still can't draw on ungrafted windows ... - (clim:sheet-adopt-child parent new) - ;; Put it just before current window, only that this has no - ;; effect with a vbox pane. - (let* ((q (remove new (clim:sheet-children parent))) - (p (position stream q))) - (clim:reorder-sheets parent - (append (subseq q 0 (1+ p)) - (list new) - (subseq q (1+ p)))) - (print (clim:sheet-children parent) *trace-output*) - (print (append (subseq q 0 p) - (list new) - (subseq q p)) - *trace-output*) - (setf (clim:sheet-enabled-p new) t) - )) - ) + (stream (clim-hunk-stream hunk)) + (parent (clim:sheet-parent stream))) + (clim:with-look-and-feel-realization + ((clim:frame-manager clim:*application-frame*) + clim:*application-frame*) + (let ((new (clim:make-pane 'clim-hunk-pane + :incremental-redisplay t + :width 100 :height 200 #|:min-height 200|# :background clim:+white+))) + (let* ((window (hi::internal-make-window)) + (hunk (make-instance 'clim-hunk :stream new))) + (setf res window) + (baba-aux device window hunk *current-buffer*) + (let ((p (position *current-window* (slot-value device 'windows)))) + (setf (slot-value device 'windows) + (append (subseq (slot-value device 'windows) 0 p) + (list window) + (subseq (slot-value device 'windows) p)))) ) + ;; since we still can't draw on ungrafted windows ... + (clim:sheet-adopt-child parent new) + ;; Put it just before current window, only that this has no + ;; effect with a vbox pane. + (let* ((q (remove new (clim:sheet-children parent))) + (p (position stream q))) + (clim:reorder-sheets parent + (append (subseq q 0 (1+ p)) + (list new) + (subseq q (1+ p)))) + (setf (clim:sheet-enabled-p new) t)))) (finish-output *trace-output*)) res) (defmethod clim:handle-repaint :around ((pane clim-hunk-pane) region) - (let ((device (device-hunk-device (slot-value pane 'hunk)))) - (with-slots (cursor-hunk) device - (when cursor-hunk - (clim-drop-cursor cursor-hunk))) - (call-next-method) - (with-slots (cursor-hunk) device - (when cursor-hunk - (clim-put-cursor cursor-hunk)))) - (clim:draw-line* (clim:sheet-medium pane) - 0 (- (clim:bounding-rectangle-height pane) 1) - (clim:bounding-rectangle-width pane) - (- (clim:bounding-rectangle-height pane) 1)) ) + (let ((w (clim:bounding-rectangle-width pane)) + (h (clim:bounding-rectangle-height pane))) + (let ((device (device-hunk-device (slot-value pane 'hunk)))) + (with-slots (cursor-hunk) device + (when cursor-hunk + (clim-drop-cursor cursor-hunk))) + (call-next-method) + (with-slots (cursor-hunk) device + (when cursor-hunk + (clim-put-cursor cursor-hunk)))) + '(clim:draw-rectangle* (clim:sheet-medium pane) + 3 3 (- w 3) (- h 20) :filled nil) )) ;;;; @@ -250,18 +299,32 @@ (defmethod clim:change-space-requirements :around ((pane clim-hunk-pane) &key (max-height nil) (height nil) - (max-width nil) (width nil) &allow-other-keys) + (max-width nil) (width nil) &allow-other-keys) nil) +#|| +(clim:make-command-table 'hemlock-menu + :errorp nil + :menu '(("File" :menu hemlock-file-menu))) +(clim:make-command-table 'hemlock-file-menu + :errorp nil + :menu '(("Open" :command com-open-file) + ("Open in another window" :command com-open-file-other-window) + ("" :divider t) + ("Exit Hemlock" :command com-exit-hemlock) + )) +||# + (clim:define-application-frame hemlock () () (:pointer-documentation t) - (:menu-bar nil) + #||(:menu-bar hemlock-menu)||# (:panes (main clim-hunk-pane :display-function nil :scroll-bars nil ;; :background (clim:make-rgb-color 0 0 1/10) ;; :foregounrd clim:+white+ :incremental-redisplay t + ;; :background (clim:make-rgb-color 1 1 9/10) :min-height 30 :min-width 30) (another clim-hunk-pane :display-function nil :scroll-bars nil @@ -281,7 +344,7 @@ ;; (clim:make-pane 'CLIM-EXTENSIONS:BOX-ADJUSTER-GADGET) ;; (1/2 another) (50 echo)))) - (:geometry :width 600 :height 800)) + (:geometry :width 600 :height 600)) (defvar *clim-hemlock-process* nil) @@ -412,11 +475,12 @@ ;; reallocate the dis-line-chars. (let* ((res (window-spare-lines window)) (new-width (max 5 (floor (- (clim:bounding-rectangle-width (clim-hunk-stream hunk)) - 10) + (* 2 *gutter*)) (slot-value hunk 'cw)))) - (new-height (max 2 (floor (- (clim:bounding-rectangle-height (clim-hunk-stream hunk)) - 10) - (slot-value hunk 'ch)))) + (new-height (max 2 (1- + (floor (- (clim:bounding-rectangle-height (clim-hunk-stream hunk)) + (* 2 *gutter*)) + (slot-value hunk 'ch))))) (width (length (the simple-string (dis-line-chars (car res)))))) (declare (list res)) (when (> new-width width) @@ -472,13 +536,14 @@ (push window (slot-value device 'windows)) (push hunk (device-hunks device)))) ;; - (let ((echo-window (hi::internal-make-window)) - (echo-hunk (make-instance 'clim-hunk :stream echo-stream))) - (baba-aux device echo-window echo-hunk *echo-area-buffer*) - (setf *echo-area-window* echo-window) - ;; why isn't this on the list of hunks? - ;; List of hunks isn't used at all. - ) + (when echo-stream ;hmm + (let ((echo-window (hi::internal-make-window)) + (echo-hunk (make-instance 'clim-hunk :stream echo-stream))) + (baba-aux device echo-window echo-hunk *echo-area-buffer*) + (setf *echo-area-window* echo-window) + ;; why isn't this on the list of hunks? + ;; List of hunks isn't used at all. + )) ;; )) @@ -489,15 +554,16 @@ (first (cons dummy-line the-sentinel)) width height) (setf - (slot-value hunk 'ts) (clim:make-text-style :fix :roman 12) - (slot-value hunk 'cw) (clim:text-style-width (slot-value hunk 'ts) (clim-hunk-stream hunk)) + (slot-value hunk 'ts) (clim:make-text-style :fix :roman 11.5) + (slot-value hunk 'cw) (+ 0 (clim:text-size (clim-hunk-stream hunk) "m" + :text-style (slot-value hunk 'ts))) (slot-value hunk 'ch) (+ 2 (clim:text-style-height (slot-value hunk 'ts) (clim-hunk-stream hunk))) width (max 5 (floor (- (clim:bounding-rectangle-width (clim-hunk-stream hunk)) - 10) + (* 2 *gutter*)) (slot-value hunk 'cw))) height (max 2 (floor (- (clim:bounding-rectangle-height (clim-hunk-stream hunk)) - 10) + (* 2 *gutter*)) (slot-value hunk 'ch))) (device-hunk-window hunk) window (device-hunk-position hunk) 0 @@ -532,7 +598,21 @@ (window-display-recentering window) nil ; ) + (loop for i from 32 below 126 do + (let ((s (string (code-char i)))) + (let ((w (clim:text-size (clim-hunk-stream hunk) s + :text-style (slot-value hunk 'ts)))) + (unless (= w 7) + (print s *trace-output*))))) + (finish-output *trace-output*) + (baba-make-dis-lines window width height) + + (when t ;;modelinep + (setup-modeline-image buffer window) + #+NIL + (setf (bitmap-hunk-modeline-dis-line hunk) + (window-modeline-dis-line window))) (push window (buffer-windows buffer)) (push window *window-list*) @@ -552,6 +632,14 @@ (defmethod device-dumb-redisplay ((device clim-device) window) (clim-drop-cursor (window-hunk window)) (let ((*standard-output* (clim-hunk-stream (window-hunk window)))) + (let ((w (clim:bounding-rectangle-width *standard-output*)) + (h (clim:bounding-rectangle-height *standard-output*))) + (clim:updating-output (t :unique-id :static :cache-value h) + (clim:draw-rectangle* *standard-output* + 1 1 + (- w 2) (- h 2) + :ink clim:+black+ + :filled nil) )) (clim:with-text-style (*standard-output* (slot-value (window-hunk window) 'ts)) (clim:updating-output (*standard-output*) (let* ((hunk (window-hunk window)) @@ -564,59 +652,68 @@ (clim-dumb-line-redisplay hunk (car dl))) (setf (window-first-changed window) the-sentinel (window-last-changed window) first) - #+NIL + #+NIL ;### (when (window-modeline-buffer window) - (hunk-replace-modeline hunk) + ;;(hunk-replace-modeline hunk) + (clim:with-text-style (*standard-output* (clim:make-text-style :serif :italic 12)) + (clim-dumb-line-redisplay hunk + (window-modeline-dis-line window) + t)) (setf (dis-line-flags (window-modeline-dis-line window)) unaltered-bits)) #+NIL (setf (bitmap-hunk-start hunk) (cdr (window-first-line window)))))) - (clim:redisplay-frame-pane clim:*application-frame* *standard-output*)) - (clim-put-cursor (window-hunk window)) - (force-output *standard-output*) ) + (clim:redisplay-frame-pane clim:*application-frame* *standard-output*) + (clim-put-cursor (window-hunk window)) + ;;(force-output *standard-output*) + (clim:medium-finish-output (clim:sheet-medium *standard-output*)) + )) -(defun clim-dumb-line-redisplay (hunk dl) +(defun clim-dumb-line-redisplay (hunk dl &optional modelinep) (let* ((stream (clim-hunk-stream hunk)) (h (slot-value hunk 'ch)) (w (slot-value hunk 'cw)) - (xo 5) - (yo 5)) + (xo *gutter*) + (yo *gutter*)) (declare (ignorable stream)) ;; (print dl *trace-output*)(finish-output *trace-output*) (unless (zerop (dis-line-flags dl)) (setf (hi::dis-line-tick dl) (incf *tick*))) (let ((chrs (dis-line-chars dl))) (clim:updating-output (*standard-output* ;### - :unique-id (dis-line-position dl) + :unique-id (if modelinep :modeline (dis-line-position dl)) + :id-test #'eq ;### :cache-value (hi::dis-line-tick dl) :cache-test #'eql) - (clim:draw-rectangle* - *standard-output* - (+ xo 0) - (+ yo (* (dis-line-position dl) h)) - (+ xo 800) - (+ yo (* (1+ (dis-line-position dl)) h)) - :ink clim:+white+) - ;; font changes - (let ((font 0) ;### - (start 0) - (end (dis-line-length dl)) - (changes (dis-line-font-changes dl))) - (loop - (cond ((null changes) - (clim-draw-text *standard-output* chrs - (+ xo (* w start)) - (+ yo 1 (* (dis-line-position dl) h)) - start end font) - (return)) - (t - (clim-draw-text *standard-output* chrs - (+ xo (* w start)) - (+ yo 1 (* (dis-line-position dl) h)) - start (font-change-x changes) font) - (setf font (font-change-font changes) - start (font-change-x changes) - changes (font-change-next changes)))))) ))) + (let ((y (+ yo (* (dis-line-position dl) h)))) + (when modelinep + (setf y (- (clim:bounding-rectangle-height *standard-output*) + h + 2))) + (clim:draw-rectangle* *standard-output* + (+ xo 0) y + (clim:bounding-rectangle-width *standard-output*) (+ y h) + :ink clim:+white+) + ;; font changes + (let ((font 0) ;### + (start 0) + (end (dis-line-length dl)) + (changes (dis-line-font-changes dl))) + (loop + (cond ((null changes) + (clim-draw-text *standard-output* chrs + (+ xo (* w start)) + (+ 1 y) + start end font) + (return)) + (t + (clim-draw-text *standard-output* chrs + (+ xo (* w start)) + (+ 1 y) + start (font-change-x changes) font) + (setf font (font-change-font changes) + start (font-change-x changes) + changes (font-change-next changes)))))) )))) (setf (dis-line-flags dl) unaltered-bits (dis-line-delta dl) 0)) (defun clim-draw-text (stream string x y start end font) @@ -626,9 +723,10 @@ (clim:draw-rectangle* stream x (1- y) (+ x dx) (+ y ch 1) :ink (hemlock-font-background font))) - (clim:draw-text* stream string x y + (clim:draw-text* stream string x (+ y (clim:text-style-ascent (clim:medium-text-style stream) + stream)) :start start :end end - :align-y :top + ;; :align-y :top ### :align-y is borken. :ink (hemlock-font-foreground font)) (when (= font 5) (let ((ch (clim:text-style-height (clim:medium-text-style stream) @@ -640,21 +738,22 @@ (with-slots (cx cy cw ch) hunk (when (and cx cy) (clim:draw-rectangle* (clim:sheet-medium (clim-hunk-stream hunk)) - (+ 5 (* cx cw)) - (+ 5 (* cy ch)) - (+ 5 (* (1+ cx) cw)) - (+ 5 (* (1+ cy) ch)) + (+ *gutter* (* cx cw)) + (+ *gutter* (* cy ch)) + (+ *gutter* (* (1+ cx) cw)) + (+ *gutter* (* (1+ cy) ch)) :ink clim:+flipping-ink+)))) (defun clim-put-cursor (hunk) (with-slots (cx cy cw ch) hunk (when (and cx cy) (clim:draw-rectangle* (clim:sheet-medium (clim-hunk-stream hunk)) - (+ 5 (* cx cw)) - (+ 5 (* cy ch)) - (+ 5 (* (1+ cx) cw)) - (+ 5 (* (1+ cy) ch)) + (+ *gutter* (* cx cw)) + (+ *gutter* (* cy ch)) + (+ *gutter* (* (1+ cx) cw)) + (+ *gutter* (* (1+ cy) ch)) :ink clim:+flipping-ink+)))) + (defun hi::editor-sleep (time) "Sleep for approximately Time seconds." (setf time 0) ;CLIM event processing still is messy. @@ -693,7 +792,102 @@ (3 (clim:make-rgb-color 1 .9 .8)) (otherwise clim:+white+))) +(defun hi::invoke-with-pop-up-display (cont buffer-name height) + (funcall cont *trace-output*) + (finish-output *trace-output*)) + +;;;; + +(clim:define-application-frame layout-test () + () + (:panes + (foo :application) + (bar :application) + (baz :interactor)) + (:layouts + (default + (clim:vertically () + foo + bar + baz)) + (dada + (clim:vertically () + (10 foo) + (10 bar) + baz)))) + +#+NIL +(define-layout-test-command (com-foo :name t) () + (let* ((foo (CLIM-INTERNALS::FIND-PANE-FOR-LAYOUT 'foo clim:*application-frame*)) + (bar (CLIM-INTERNALS::FIND-PANE-FOR-LAYOUT 'bar clim:*application-frame*)) + (baz (CLIM-INTERNALS::FIND-PANE-FOR-LAYOUT 'baz clim:*application-frame*)) + (vbox (clim:sheet-parent foo)) + (vbox.parent (clim:sheet-parent vbox))) + (clim:sheet-disown-child vbox.parent vbox) + (clim:sheet-disown-child vbox foo) + (clim:sheet-disown-child vbox bar) + (clim:sheet-disown-child vbox baz) + (clim:with-look-and-feel-realization + ((clim:frame-manager clim:*application-frame*) + clim:*application-frame*) + (let ((vb (clim:make-pane 'clim:vrack-pane + :contents (list (list 100 foo) + (list 100 bar) + baz)))) + + (clim:sheet-adopt-child vbox.parent vb) + (setf (clim:sheet-enabled-p vb) t) + (setf (clim:sheet-region vb) + (clim:sheet-region vbox)) + (clim:allocate-space vb + (1- (clim:bounding-rectangle-width vb)) + (clim:bounding-rectangle-height vb)) + (eval '(trace clim:allocate-space)) + (clim:layout-frame clim:*application-frame* + (clim:bounding-rectangle-width (clim:frame-top-level-sheet clim:*application-frame*)) + (clim:bounding-rectangle-height (clim:frame-top-level-sheet clim:*application-frame*))) + (eval '(untrace clim:allocate-space)) + )))) + +(defparameter *app-process-hash* (make-hash-table)) + +(defun run (app) + (when (gethash app *app-process-hash*) + (clim-sys:destroy-process (gethash app *app-process-hash*))) + (setf (gethash app *app-process-hash*) + (clim-sys:make-process (lambda () + (clim:run-frame-top-level + (clim:make-application-frame app)))))) + + +#+NIL +(defparameter mcclim-freetype::*families/faces* + '(;; ((:fix :roman) . "/var/lib/defoma/fontconfig.d/B/Bitstream-Vera-Serif.ttf") + ((:fix :roman) . "/usr/share/fonts/truetype/ttf-bitstream-vera/VeraMono.ttf") + ((:fix :italic) . "/usr/share/fonts/truetype/ttf-bitstream-vera/VeraMoIt.ttf") + ((:fix :bold-italic) . "/usr/share/fonts/truetype/ttf-bitstream-vera/VeraMoBI.ttf") + ((:fix :italic-bold) . "/usr/share/fonts/truetype/ttf-bitstream-vera/VeraMoBI.ttf") + ((:fix :bold) . "/usr/share/fonts/truetype/ttf-bitstream-vera/VeraMoBd.ttf") + + ((:serif :roman) . "/usr/share/fonts/truetype/freefont/FreeSerif.ttf") + ((:serif :italic) . "/usr/share/fonts/truetype/freefont/FreeSerifItalic.ttf") + ((:serif :bold-italic) . "/usr/share/fonts/truetype/freefont/FreeSerifBoldItalic.ttf") + ((:serif :italic-bold) . "/usr/share/fonts/truetype/freefont/FreeSerifBoldItalic.ttf") + ((:serif :bold) . "/usr/share/fonts/truetype/freefont/FreeSerifBold.ttf") + + ((:sans-serif :roman) . "/usr/share/fonts/truetype/ttf-bitstream-vera/Vera.ttf") + ((:sans-serif :italic) . "/usr/share/fonts/truetype/ttf-bitstream-vera/VeraIt.ttf") + ((:sans-serif :bold-italic) . "/usr/share/fonts/truetype/ttf-bitstream-vera/VeraBI.ttf") + ((:sans-serif :italic-bold) . "/usr/share/fonts/truetype/ttf-bitstream-vera/VeraBI.ttf") + ((:sans-serif :bold) . "/usr/share/fonts/truetype/ttf-bitstream-vera/VeraBd.ttf") + )) + + + ;; $Log: foo.lisp,v $ +;; Revision 1.6 2004/12/27 18:53:20 gbaumann +;; half-way working undo +;; ;; Revision 1.5 2004/12/15 12:16:43 crhodes ;; Make clim-hemlock basically work on sbcl -- mostly build fixes from Hannu ;; Koivisto. @@ -706,3 +900,5 @@ ;; Basic support for c-x 1 and c-x 2. ;; + +

1 0

[Phemlock-cvs] CVS update: phemlock/src/new-undo.lisp
by gbaumann＠common-lisp.net 27 Dec '04

27 Dec '04

Update of /project/phemlock/cvsroot/phemlock/src In directory common-lisp.net:/tmp/cvs-serv1172/src Modified Files: new-undo.lisp Log Message: half-way working undo Date: Mon Dec 27 19:53:18 2004 Author: gbaumann Index: phemlock/src/new-undo.lisp diff -u phemlock/src/new-undo.lisp:1.2 phemlock/src/new-undo.lisp:1.3 --- phemlock/src/new-undo.lisp:1.2 Fri Dec 24 00:58:24 2004 +++ phemlock/src/new-undo.lisp Mon Dec 27 19:53:18 2004 @@ -1,28 +1,78 @@ -(in-package :hemlock-internals) - -(defvar *log* nil) +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: HEMLOCK-INTERNALS; -*- +;;; --------------------------------------------------------------------------- +;;; Title: Prelimiary Undo +;;; Created: 2004-12-26 +;;; Author: Gilbert Baumann <gilbert(a)base-engineering.com> +;;; License: MIT style (see below) +;;; --------------------------------------------------------------------------- +;;; (c) copyright 2004 by Gilbert Baumann + +;;; Permission is hereby granted, free of charge, to any person obtaining +;;; a copy of this software and associated documentation files (the +;;; "Software"), to deal in the Software without restriction, including +;;; without limitation the rights to use, copy, modify, merge, publish, +;;; distribute, sublicense, and/or sell copies of the Software, and to +;;; permit persons to whom the Software is furnished to do so, subject to +;;; the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be +;;; included in all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +;;;; TODO + +;; - Undo information must be per buffer. And don't record information +;; on anonymous buffers. +;; - Record the position of the point too. +;; - Some form of consolidation +;; - Redo +;; - Ensure that what we indentified as a protocol of functions +;; modifying a buffer is not violated. Both by runtime and compile +;; time measures. +;; - Hook into the command processor so that the Undo command undoes +;; exactly one [user] command. +;; - Look and Feel: +;; Find out what different variants of undo are implemented both +;; with gnu emacs and xemacs, try to simulate those. +;; - Q: Are there any commands that modify more than one buffer? +;; (Besides the kill ring and stuff) +;; - FILTER-REGION (function region) is missing +;; - (SETF NEXT-CHARACTER) (character mark) is missing +;; - Don't record undo information of functions that don't modify the +;; buffer at all. + +;; There is this MODIFYING-BUFFER which should enable access to +;; LINE-NEXT and LINE-PREVIOUS. + +;; Instead of putting :command entires onto an undo list, do +;; undo-chunks directly. + +;; Q: Do we need a separate Redo command or should we go the route +;; that XEmacs follows and make any other command than undo change +;; the current undo sequence and let subsequent undos really redo +;; stuff? This is useful but awkward. + +;; Also: I really want the self-insert-commands be grouped by words +;; and not just by 20 characters as the [documented] behaviour of +;; XEmacs. This also is the observed behavior. -;;; Ouch! this all isn't _that_ easy. +;; Find a better place for buffer-undo-list and also provide for +;; buffers that don't record undo information. -;; (defmacro add-logging (attr) -;; `(defmethod (setf ,attr) :around (new-value line) -;; (let ((old (,attr line))) -;; (push `(,',attr ,line ,old ,new-value) *log*)) -;; (call-next-method))) - -;; (add-logging line-previous) -;; (add-logging line-next) -;; (add-logging mark-line) - -;; (defun dada () -;; (let ((log *log*) -;; (*log* nil)) -;; (dolist (k log) -;; (destructuring-bind (slot object old new) k -;; (funcall (fdefinition `(setf ,slot)) old object))))) -;;;; +(in-package :hemlock-internals) -(defvar *performing-undo* nil) +;; Unfortunately we need numeric buffer positions. (Hmm, maybe after +;; all RMS has a point?) Anyhow to graft this onto hemlock we define +;; two functions MARK-POSITION and POSTION-MARK to convert and back +;; and fro. Further these new kind of buffer positions are passed +;; around as (buffer line-number character-position) triples. (defun mark-position (mark) (let ((line-no 0) @@ -34,105 +84,135 @@ (list (line-buffer (mark-line mark)) line-no (mark-charpos mark)))) -;;; below, I am not quite sure about left vs. right inserting --amb +(defun position-mark (buffer line-no char-pos) + (let ((line (mark-line (buffer-start-mark buffer)))) + (dotimes (i line-no) + (setf line (line-next line))) + (mark line char-pos))) + +;;;; buffer-undo-list + +(defparameter *bul-hash* + (make-hash-table :test #'eq)) + +(defun buffer-undo-list (buffer) + (gethash buffer *bul-hash*) ) + +(defun (setf buffer-undo-list) (new-value buffer) + (setf (gethash buffer *bul-hash*) new-value)) + +;;;; Insertion (defmethod insert-character :around (mark character) - (with-mark ((start mark :right-inserting)) - (prog1 - (call-next-method) - (unless (or *performing-undo* - (eq (line-buffer (mark-line mark)) *echo-area-buffer*)) - (push `(delete-characters ,(mark-position start)) *log*))))) + (push `(insert-string ,(mark-position mark) ,(string character)) + (buffer-undo-list (line-buffer (mark-line mark)))) + (call-next-method)) (defmethod insert-string :around (mark string &optional (start 0) (end (length string))) - (if (car (mark-position mark)) ; used with kill-ring? - (progn - (with-mark ((start mark :right-inserting) - (end mark :left-inserting)) - (prog1 - (call-next-method) - (unless (or *performing-undo* - (eq (line-buffer (mark-line mark)) *echo-area-buffer*)) - (push - `(delete-region ,(mark-position start) ,(mark-position end)) - *log*))))) - (call-next-method))) + (push `(insert-string ,(mark-position mark) ,(subseq string start end)) + (buffer-undo-list (line-buffer (mark-line mark)))) + (call-next-method)) (defmethod insert-region :around (mark region) - (with-mark ((start mark :right-inserting) - (end mark :left-inserting)) - (prog1 - (call-next-method) - (unless (or *performing-undo* - (eq (line-buffer (mark-line mark)) *echo-area-buffer*)) - (push - `(delete-region ,(mark-position start) ,(mark-position end)) - *log*))))) + (push `(insert-string ,(mark-position mark) ,(region-to-string region)) + (buffer-undo-list (line-buffer (mark-line mark)))) + (call-next-method)) + +(defmethod ninsert-region :around (mark region) + ;; the "n" refers to the region argument. + (push `(insert-region ,(mark-position mark) ,(region-to-string region)) + (buffer-undo-list (line-buffer (mark-line mark)))) + (call-next-method)) + +;;;; Deletion + +;; We make delete-characters and delete-region both call off to +;; delete-and-save-region which is the most general method and has the +;; benefit to return the deleted stuff. (defmethod delete-characters :around (mark &optional (n 1)) - (with-mark ((start mark :right-inserting) - (end mark :left-inserting)) - (character-offset end n) - (let ((string (region-to-string (region start end)))) - (prog1 - (call-next-method) - (unless (or *performing-undo* - (eq (line-buffer (mark-line mark)) *echo-area-buffer*)) - (push - `(insert-string ,(mark-position start) ,string) - *log*)))))) + ;; For now delete-characters just calls delete-region in any case. + ;; code borrowed from htext4.lisp + (let* ((line (mark-line mark)) + (charpos (mark-charpos mark)) + (length (line-length* line))) + (setf (mark-line *internal-temp-mark*) line + (mark-charpos *internal-temp-mark*) charpos) + (let ((other-mark (character-offset *internal-temp-mark* n))) + (cond + (other-mark + (if (< n 0) + (setf (region-start *internal-temp-region*) other-mark + (region-end *internal-temp-region*) mark) + (setf (region-start *internal-temp-region*) mark + (region-end *internal-temp-region*) other-mark)) + (delete-and-save-region *internal-temp-region*) + t) + (t nil))))) (defmethod delete-region :around (region) - (with-mark ((start (region-start region) :right-inserting) - (end (region-end region) :left-inserting)) - (let ((string (region-to-string region))) - (prog1 - (call-next-method) - (unless (or *performing-undo* - (eq (line-buffer (mark-line (region-start region))) - *echo-area-buffer*)) - (push - `(insert-string ,(mark-position start) ,string) - *log*)))))) + (delete-and-save-region region)) (defmethod delete-and-save-region :around (region) - (with-mark ((start (region-start region) :right-inserting) - (end (region-end region) :left-inserting)) - (let ((string (region-to-string region))) - (prog1 - (call-next-method) - (unless (or *performing-undo* - (eq (line-buffer (mark-line (region-start region))) - *echo-area-buffer*)) - (push - `(insert-string ,(mark-position start) ,string) - *log*)))))) - -(defun dada () - (let ((*performing-undo* t)) - (do ((k (pop *log*) (pop *log*))) - ((null k)) - (undo k)))) - -(defun undo (k) - (ecase (car k) - (delete-characters - (destructuring-bind ((buffer line-no char-pos)) (cdr k) - (delete-characters (position-mark buffer line-no char-pos)))) - (delete-region - (destructuring-bind ((buffer1 line-no1 char-pos1) - (buffer2 line-no2 char-pos2)) (cdr k) - (delete-region - (region (position-mark buffer1 line-no1 char-pos1) - (position-mark buffer2 line-no2 char-pos2))))) - (insert-string - (destructuring-bind ((buffer line-no char-pos) string) (cdr k) - (insert-string (position-mark buffer line-no char-pos) string))))) + (let ((pos (mark-position (region-start region))) + (matter (call-next-method))) + (push `(delete-region ,pos ,(region-to-string matter)) + (buffer-undo-list (car pos))) + matter)) -(defun position-mark (buffer line-no char-pos) - (let ((line (mark-line (buffer-start-mark buffer)))) - (dotimes (i line-no) - (if line - (setf line (line-next line)) - (error "Line is NIL"))) - (mark line char-pos))) \ No newline at end of file +;;;; + +(defvar last-was-undo-p nil) +(defvar this-is-undo-p nil) +(defvar undoing-undo-list nil) + +(defcommand "New Undo" (p) + "" + "" + (setf this-is-undo-p t) + ;; ### pop the "New Undo" log entry + (let ((buffer (current-buffer)) + (undo-list (if last-was-undo-p + undoing-undo-list + (cddr (buffer-undo-list (current-buffer)))))) + (block baz + (loop + (let ((chunk (pop undo-list))) + (when (or (eq (car chunk) :command) + (null chunk)) + (message "~S" (cadr chunk)) + (return-from baz nil)) + (when (and chunk (consp (cadr chunk)) (eq (car (cadr chunk)) buffer)) + (case (car chunk) + (insert-string + (let ((p (cadr chunk)) + (n (length (caddr chunk)))) + (let () + (delete-characters (apply #'position-mark p) n) + + ))) + (delete-region + (let ((p (cadr chunk)) + (matter (caddr chunk))) + (let () + (insert-string (apply #'position-mark p) matter) + ))) + (point-position + (move-mark (current-point) (apply #'position-mark (cadr chunk)))) ))))) + + (setf undoing-undo-list undo-list) )) + +(defun new-undo-invoke-hook (command p) + (setf this-is-undo-p nil) + (setf *b* (current-buffer)) + (push (list :command command) (buffer-undo-list (current-buffer))) + (push (list 'point-position (mark-position (current-point))) + (buffer-undo-list (current-buffer))) ) + +(defparameter *invoke-hook* #'(lambda (command p) + (new-undo-invoke-hook command p) + (funcall (command-function command) p) + (setf last-was-undo-p this-is-undo-p)) + "This function is called by the command interpreter when it wants to invoke a + command. The arguments are the command to invoke and the prefix argument. + The default value just calls the Command-Function with the prefix argument.")

1 0

[Phemlock-cvs] CVS update: phemlock/TODO phemlock/hemlock.asd phemlock/hemlock.system
by gbaumann＠common-lisp.net 27 Dec '04

27 Dec '04

Update of /project/phemlock/cvsroot/phemlock In directory common-lisp.net:/tmp/cvs-serv1172 Modified Files: TODO hemlock.asd hemlock.system Log Message: half-way working undo Date: Mon Dec 27 19:53:14 2004 Author: gbaumann Index: phemlock/TODO diff -u phemlock/TODO:1.1.1.1 phemlock/TODO:1.2 --- phemlock/TODO:1.1.1.1 Fri Jul 9 15:36:33 2004 +++ phemlock/TODO Mon Dec 27 19:53:14 2004 @@ -18,4 +18,18 @@ - Import the scribe parser and work on the html converter -$Id: TODO,v 1.1.1.1 2004/07/09 13:36:33 gbaumann Exp $ \ No newline at end of file +HEMLOCK AS A GADGET + +I want Hemlock as a gadget for McCLIM. The easiest route to get that is to +have a hemlock run in another thread and pass input events in as the gadget +receives them. Redisplay should be done though accessing the dis-lines of +Hemlock's idea of the window. When arguments are asked for in the echo +buffer, pop up a little window near the cursor and ask there. [could also +been done in real Hemlock]. When we run Hemlock as a gadget disallow +changing windows or changing buffers. + +HEMLOCK AS THE DEFAULT COMMAND LINE EDITOR IN CLIM + + + +$Id: TODO,v 1.2 2004/12/27 18:53:14 gbaumann Exp $ Index: phemlock/hemlock.asd diff -u phemlock/hemlock.asd:1.5 phemlock/hemlock.asd:1.6 --- phemlock/hemlock.asd:1.5 Wed Dec 15 01:51:35 2004 +++ phemlock/hemlock.asd Mon Dec 27 19:53:14 2004 @@ -157,7 +157,8 @@ (:file "streams") #+port-root-hacks (:file "hacks") (:file "main") - (:file "echo"))) + (:file "echo") + (:file "new-undo"))) (:module user-1 :pathname #.(merge-pathnames (make-pathname @@ -241,4 +242,4 @@ :components ((:file "patch") (:file "foo") - #+port-clim-exp-syntax (:file "exp-syntax"))))) \ No newline at end of file + #+port-clim-exp-syntax (:file "exp-syntax"))))) Index: phemlock/hemlock.system diff -u phemlock/hemlock.system:1.5 phemlock/hemlock.system:1.6 --- phemlock/hemlock.system:1.5 Wed Dec 15 01:51:35 2004 +++ phemlock/hemlock.system Mon Dec 27 19:53:14 2004 @@ -137,7 +137,8 @@ (:file "streams") #+port-root-hacks (:file "hacks") (:file "main") - (:file "echo"))) + (:file "echo") + (:file "new-undo"))) (:module user-1 :source-pathname "user" :depends-on (root-2) @@ -211,5 +212,4 @@ :depends-on (bitmap-2) :components ((:file "patch") - #+port-clim-foo (:file "foo") - (:file "exp-syntax"))))) \ No newline at end of file + (:file "foo") ))))

1 0

[Phemlock-cvs] CVS update: phemlock/src/core/htext3.lisp phemlock/src/core/htext4.lisp
by abakic＠common-lisp.net 23 Dec '04

23 Dec '04

Update of /project/phemlock/cvsroot/phemlock/src/core In directory common-lisp.net:/tmp/cvs-serv12917/src/core Modified Files: htext3.lisp htext4.lisp Log Message: Identified initial, partial "undo protocol". Date: Fri Dec 24 00:58:30 2004 Author: abakic Index: phemlock/src/core/htext3.lisp diff -u phemlock/src/core/htext3.lisp:1.1 phemlock/src/core/htext3.lisp:1.2 --- phemlock/src/core/htext3.lisp:1.1 Fri Jul 9 17:00:36 2004 +++ phemlock/src/core/htext3.lisp Fri Dec 24 00:58:28 2004 @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; #+CMU (ext:file-comment - "$Header: /project/phemlock/cvsroot/phemlock/src/core/htext3.lisp,v 1.1 2004/07/09 15:00:36 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/htext3.lisp,v 1.2 2004/12/23 23:58:28 abakic Exp $") ;;; ;;; ********************************************************************** ;;; @@ -100,7 +100,7 @@ (defconstant line-number-interval-guess 8 "Our first guess at how we should number an inserted region's lines.") -(defun insert-region (mark region) +(defmethod insert-region (mark region) "Inserts the given Region at the Mark." (let* ((start (region-start region)) (end (region-end region)) Index: phemlock/src/core/htext4.lisp diff -u phemlock/src/core/htext4.lisp:1.1 phemlock/src/core/htext4.lisp:1.2 --- phemlock/src/core/htext4.lisp:1.1 Fri Jul 9 17:00:36 2004 +++ phemlock/src/core/htext4.lisp Fri Dec 24 00:58:29 2004 @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; #+CMU (ext:file-comment - "$Header: /project/phemlock/cvsroot/phemlock/src/core/htext4.lisp,v 1.1 2004/07/09 15:00:36 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/htext4.lisp,v 1.2 2004/12/23 23:58:29 abakic Exp $") ;;; ;;; ********************************************************************** ;;; @@ -71,7 +71,7 @@ ;;;; DELETE-REGION. -(defun delete-region (region) +(defmethod delete-region (region) "Deletes the Region." (let* ((start (region-start region)) (end (region-end region)) @@ -139,7 +139,7 @@ ;;;; DELETE-AND-SAVE-REGION. -(defun delete-and-save-region (region) +(defmethod delete-and-save-region (region) "Deletes Region and returns a region containing the deleted characters." (let* ((start (region-start region)) (end (region-end region))

1 0