From abakic at common-lisp.net  Mon Nov  1 22:16:19 2004
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Mon, 01 Nov 2004 22:16:19 -0000
Subject: [Phemlock-cvs] CVS update: phemlock/INSTALL 
Message-ID: <E1COkTF-0007V4-00@common-lisp.net>

Update of /project/phemlock/cvsroot/phemlock
In directory common-lisp.net:/tmp/cvs-serv28512

Modified Files:
	INSTALL 
Log Message:
Some more details about CMUCL and SBCL installation.

Date: Mon Nov  1 23:16:12 2004
Author: abakic

Index: phemlock/INSTALL
diff -u phemlock/INSTALL:1.3 phemlock/INSTALL:1.4
--- phemlock/INSTALL:1.3	Sat Sep  4 01:06:43 2004
+++ phemlock/INSTALL	Mon Nov  1 23:16:11 2004
@@ -1,22 +1,33 @@
                           INSTALLATION NOTES
 
-Phemlock comes with a mk:defsystem style .system file. So when you are
-lucky you just can fire up your Lisp and say
-
-    (oos :hemlock :load)
+Phemlock comes with a mk:defsystem style .system file. ASDF system
+file hemlock.asd has been added, supporting SBCL for now. So when you
+are lucky you just can fire up your Lisp and say
+
+CMUCL/MK:
+    ; (require 'defsystem)
+    (mk:load-system :hemlock)
+
+SBCL/ASDF:
+    ; (require 'asdf)
+    ; (require 'sb-bsd-sockets)
+    ; (asdf:oos 'asdf:load-op :clx)
+    (asdf:oos 'adsf:load-op :hemlock)
 
     (cl-user::hemlock)
 
 If you want to try the CLIM backend, which not yet is fully operational, try:
 
+    ; (load "../McCLIM/system.lisp")
+    ; (mk:load-system :clim-clx) ; CMUCL/MK, might already be a dependency
+    ; (asdf:oos 'asdf:load-op :clim-clx) ; SBCL/ASDF
+
     (clim-hemlock::clim-hemlock)
 
 
 This was tested with:
 
- - CMUCL
+ - CMUCL (with CLX library) using McCLIM
+ - SBCL using McCLIM, CLX
  - ACL
- - CLISP using MIT CLX
-
-
-ASDF system file hemlock.asd has been added, supporting SBCL for now.
\ No newline at end of file
+ - CLISP using MIT CLX
\ No newline at end of file




From gbaumann at common-lisp.net  Sun Nov 21 01:03:52 2004
From: gbaumann at common-lisp.net (Gilbert Baumann)
Date: Sun, 21 Nov 2004 02:03:52 +0100
Subject: [Phemlock-cvs] CVS update: phemlock/src/clim/foo.lisp 
Message-ID: <E1CVg8u-0004DS-00@common-lisp.net>

Update of /project/phemlock/cvsroot/phemlock/src/clim
In directory common-lisp.net:/tmp/cvs-serv16202

Modified Files:
	foo.lisp 
Log Message:
Basic support for c-x 1 and c-x 2.

Date: Sun Nov 21 02:03:51 2004
Author: gbaumann

Index: phemlock/src/clim/foo.lisp
diff -u phemlock/src/clim/foo.lisp:1.3 phemlock/src/clim/foo.lisp:1.4
--- phemlock/src/clim/foo.lisp:1.3	Sat Sep  4 01:06:50 2004
+++ phemlock/src/clim/foo.lisp	Sun Nov 21 02:03:51 2004
@@ -1,3 +1,11 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-HEMLOCK; -*-
+;;; ---------------------------------------------------------------------------
+;;;     Title: CLIM Phemlock
+;;;   Created: 2004-11-20       <- not true!
+;;;    Author: Gilbert Baumann <gilbert at base-engineering.com>
+;;; ---------------------------------------------------------------------------
+;;;  (c) copyright 2003, 2004 by Gilbert Baumann
+
 (in-package :clim-hemlock)
 
 ;;;; RANDOM NOTES
@@ -17,17 +25,28 @@
 ;; where we can't switch buffers. And line editing buffers and text-field
 ;; buffers should be hidden. => Notion of a session.
 
+;; - 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
+
+;; - 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.")))
+                :documentation "The hunk that has the cursor.")
+   (windows :initform nil
+            )
+   ))
 
 (defmethod device-init ((device clim-device))
   )
 
-(defmethod device-make-window ((device clim-device) start modelinep window font-family
-                                ask-user x y width-arg height-arg proportion))
-
 (defmethod device-exit ((device clim-device)))
 
 (defmethod device-smart-redisplay ((device clim-device) window)
@@ -63,15 +82,97 @@
 (defmethod device-show-mark ((device clim-device) window x y time)
   )
 
+;;;; Windows
+
+;; In CLIM Hemlock each window is a single pane, which should keep
+;; things simple. We do not yet have the notion of window groups.
+
 (defmethod device-next-window ((device clim-device) window)
-  )
+  (with-slots (windows) device
+    (elt windows (mod (1+ (position window windows))
+                      (length windows)))))
 
 (defmethod device-previous-window ((device clim-device) window)
-  )
+  (with-slots (windows) device
+    (elt windows (mod (1- (position window windows))
+                      (length windows)))))
 
 (defmethod device-delete-window ((device clim-device) window)
+  (let* ((hunk (window-hunk window))
+         (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)))
+    (let ((buffer (window-buffer window)))
+      (setf (buffer-windows buffer) (delete window (buffer-windows buffer))))
+    )
   )
 
+(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*)
+  (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)
+          ))
+      )
+    (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)) )
+
+
+;;;; 
+
 (defmethod device-random-typeout-full-more ((device clim-device) stream)
   )
 
@@ -97,8 +198,7 @@
    (cy :initarg :cy :initform nil)
    (cw)
    (ch)
-   (ts)
-   ))
+   (ts)))
 
 ;;; Input
 
@@ -136,38 +236,68 @@
 
 ;;;; There is awful lot to do to boot a device.
 
-;; For now a hemlock window and hunk is paralleled in a pane.
+(defclass clim-hunk-pane (CLIM:APPLICATION-PANE)
+  ((hunk)
+   ))
+
+(defmethod clim:note-sheet-region-changed :after ((sheet clim-hunk-pane))
+  (when (slot-boundp sheet 'hunk)
+    (clim-window-changed (slot-value sheet 'hunk))
+    (hi::internal-redisplay))
+  (print 'hi-there *trace-output*)
+  (finish-output *trace-output*))
+
+(defmethod clim:change-space-requirements :around
+    ((pane clim-hunk-pane)
+     &key (max-height nil) (height nil)
+     (max-width nil) (width nil) &allow-other-keys)
+  nil)
 
 (clim:define-application-frame hemlock ()
     ()
   (:pointer-documentation t)
   (:menu-bar nil)
   (:panes
-   (main :application :display-function nil :scroll-bars nil
+   (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
+    :min-height 30
+    :min-width 30)
+   (another clim-hunk-pane :display-function nil :scroll-bars nil
     ;; :background (clim:make-rgb-color 0 0 1/10)
     ;; :foregounrd clim:+white+
-    :incremental-redisplay t)
+    :incremental-redisplay t
+    :min-height 30
+    :min-width 30
+    )
    ;; (echo :application :display-function nil :scroll-bars nil)
-   (io   :interactor))
+   (echo clim-hunk-pane :scroll-bars nil :display-function nil :incremental-redisplay t
+    :min-height 30))
   (:layouts
    (default
-       (clim:vertically (:width 815)
-         (510 main)
-         ;; (100 echo)
-         (100 io))))
+       (clim:vertically ()
+         (1/2 main)
+         ;; (clim:make-pane 'CLIM-EXTENSIONS:BOX-ADJUSTER-GADGET)
+         ;; (1/2 another)
+         (50 echo))))
   (:geometry :width 600 :height 800))
 
-(defun clim-hemlock ()
-  (clim:run-frame-top-level
-   (clim:make-application-frame 'hemlock)))
+(defvar *clim-hemlock-process* nil)
 
-(defparameter *sheet* nil)
+(defun clim-hemlock ()
+  (when *clim-hemlock-process*
+    (mp:destroy-process *clim-hemlock-process*))
+  (setf *clim-hemlock-process*
+        (clim-sys:make-process
+         (lambda ()
+           (clim:run-frame-top-level
+            (clim:make-application-frame 'hemlock))))))
 
 ;; *editor-windowed-input* is hack and points to the display in CLX hemlock
 ;; *editor-input* is the real input stream.
 ;; who sets up *real-editor-input* ?
 
-
 (defmethod clim:default-frame-top-level ((frame hemlock)
                                          &key
                                          (command-parser 'command-line-command-parser)
@@ -179,7 +309,6 @@
 		      partial-command-parser
 		      prompt))
   (let ((clim:*application-frame* frame))
-    (setf *sheet* (clim:frame-standard-output frame))
     (let ((*window-list* *window-list*)
           (*editor-input*
            (let ((e (hi::make-input-event)))
@@ -187,27 +316,24 @@
                             :stream (clim:frame-standard-input frame)
                             :head e :tail e))))
       (setf hi::*real-editor-input* *editor-input*) ;###
-      (baba (clim:frame-standard-output frame)
-            (clim:frame-query-io frame))
-      (print *current-window*)
-      (print *current-buffer*)
-      (finish-output)
+      (baba (clim:get-frame-pane frame 'main) ;; (clim:frame-standard-output frame)
+            (clim:get-frame-pane frame 'echo)
+            nil ;;(clim:get-frame-pane frame 'another)
+            )
       ;;(eval '(trace device-put-cursor))
       ;;(eval '(trace clim:draw-text*))
       ;;(eval '(trace device-smart-redisplay device-dumb-redisplay hi::redisplay))
-      #+NIL
-      (loop
-          (print (clim:read-gesture :stream (clim:frame-standard-input frame))
-                 (clim:frame-standard-output frame)))
-      (hi::%command-loop)
-      )))
+      (print (clim:get-frame-pane frame 'main) *trace-output*)
+      (hi::%command-loop) )))
+
+;;; Keysym translations
 
 (defun clim-character-keysym (gesture)
   (cond
     ((eql gesture #\newline)            ;### hmm
-     (hemlock-ext:KEY-EVENT-KEYSYM #k"Return"))
+     (hemlock-ext:key-event-keysym #k"Return"))
     ((eql gesture #\tab)            ;### hmm
-     (hemlock-ext:KEY-EVENT-KEYSYM #k"Tab"))
+     (hemlock-ext:key-event-keysym #k"Tab"))
     ((eql gesture #\Backspace)
      (hemlock-ext:key-event-keysym #k"Backspace"))
     ((eql gesture #\Escape)
@@ -241,8 +367,7 @@
     (:next  "pagedown")
     (:prior "pageup")
     (:f1    "f1")
-    (:escape "escape")
-    ))
+    (:escape "escape") ))
 
 (defun gesture-key-event (gesture)
   "Given a CLIM gesture returns a Hemlock key-event or NIL, if there is none."
@@ -270,103 +395,7 @@
            '(describe gesture *trace-output*)
            nil))))
 
-
-;;;;;;;;;;;;;
-
-#+NIL
-(defun window-for-hunk (hunk start modelinep)
-  (check-type start mark)
-  (setf (bitmap-hunk-changed-handler hunk) #'window-changed)
-  (let ((buffer (line-buffer (mark-line start)))
-	(first (cons dummy-line the-sentinel))
-	(width (bitmap-hunk-char-width hunk))
-	(height (bitmap-hunk-char-height hunk)))
-    (when (or (< height minimum-window-lines)
-	      (< width minimum-window-columns))
-      (error "Window too small."))
-    (unless buffer (error "Window start is not in a buffer."))
-    (let ((window
-	   (internal-make-window
-	    :hunk hunk
-	    :display-start (copy-mark start :right-inserting)
-	    :old-start (copy-mark start :temporary)
-	    :display-end (copy-mark start :right-inserting)
-	    :%buffer buffer
-	    :point (copy-mark (buffer-point buffer))
-	    :height height
-	    :width width
-	    :first-line first
-	    :last-line the-sentinel
-	    :first-changed the-sentinel
-	    :last-changed first
-	    :tick -1)))
-      (push window *window-list*)
-      (push window (buffer-windows buffer))
-      ;;
-      ;; Make the dis-lines.
-      (do ((i (- height) (1+ i))
-	   (res ()
-		(cons (make-window-dis-line (make-string width)) res)))
-	  ((= i height) (setf (window-spare-lines window) res)))
-      ;;
-      ;; Make the image up to date.
-      (update-window-image window)
-      (setf (bitmap-hunk-start hunk) (cdr (window-first-line window)))
-      ;;
-      ;; If there is a modeline, set it up.
-      (when modelinep
-	(setup-modeline-image buffer window)
-	(setf (bitmap-hunk-modeline-dis-line hunk)
-	      (window-modeline-dis-line window)))
-      window)))
-
-#||
-(defun window-changed (hunk)
-  (let ((window (bitmap-hunk-window hunk)))
-    ;;
-    ;; Nuke all the lines in the window image.
-    (unless (eq (cdr (window-first-line window)) the-sentinel)
-      (shiftf (cdr (window-last-line window))
-	      (window-spare-lines window)
-	      (cdr (window-first-line window))
-	      the-sentinel))
-    (setf (bitmap-hunk-start hunk) (cdr (window-first-line window)))
-    ;;
-    ;; Add some new spare lines if needed.  If width is greater,
-    ;; reallocate the dis-line-chars.
-    (let* ((res (window-spare-lines window))
-	   (new-width (bitmap-hunk-char-width hunk))
-	   (new-height (bitmap-hunk-char-height hunk))
-	   (width (length (the simple-string (dis-line-chars (car res))))))
-      (declare (list res))
-      (when (> new-width width)
-	(setq width new-width)
-	(dolist (dl res)
-	  (setf (dis-line-chars dl) (make-string new-width))))
-      (setf (window-height window) new-height (window-width window) new-width)
-      (do ((i (- (* new-height 2) (length res)) (1- i)))
-	  ((minusp i))
-	(push (make-window-dis-line (make-string width)) res))
-      (setf (window-spare-lines window) res)
-      ;;
-      ;; Force modeline update.
-      (let ((ml-buffer (window-modeline-buffer window)))
-	(when ml-buffer
-	  (let ((dl (window-modeline-dis-line window))
-		(chars (make-string new-width))
-		(len (min new-width (window-modeline-buffer-len window))))
-	    (setf (dis-line-old-chars dl) nil)
-	    (setf (dis-line-chars dl) chars)
-	    (replace chars ml-buffer :end1 len :end2 len)
-	    (setf (dis-line-length dl) len)
-	    (setf (dis-line-flags dl) changed-bit)))))
-    ;;
-    ;; Prepare for redisplay.
-    (setf (window-tick window) (tick))
-    (update-window-image window)
-    (when (eq window *current-window*) (maybe-recenter-window window))
-    hunk))
-||#
+;;;;
 
 (defun clim-window-changed (hunk)
   (let ((window (device-hunk-window hunk)))
@@ -377,14 +406,17 @@
 	      (window-spare-lines window)
 	      (cdr (window-first-line window))
 	      the-sentinel))
-    ;; (setf (device-hunk-start hunk) (cdr (window-first-line window)))
-    #||
+    ;### (setf (bitmap-hunk-start hunk) (cdr (window-first-line window)))
     ;;
     ;; Add some new spare lines if needed.  If width is greater,
     ;; reallocate the dis-line-chars.
     (let* ((res (window-spare-lines window))
-	   (new-width (bitmap-hunk-char-width hunk))
-	   (new-height (bitmap-hunk-char-height hunk))
+	   (new-width (max 5 (floor (- (clim:bounding-rectangle-width (clim-hunk-stream hunk))
+                                       10)
+                                    (slot-value hunk 'cw)))) 
+	   (new-height (max 2 (floor (- (clim:bounding-rectangle-height (clim-hunk-stream hunk))
+                                        10)
+                                     (slot-value hunk 'ch))))
 	   (width (length (the simple-string (dis-line-chars (car res))))))
       (declare (list res))
       (when (> new-width width)
@@ -408,7 +440,6 @@
 	    (replace chars ml-buffer :end1 len :end2 len)
 	    (setf (dis-line-length dl) len)
 	    (setf (dis-line-flags dl) changed-bit)))))
-    ||#
     ;;
     ;; Prepare for redisplay.
     (setf (window-tick window) (tick))
@@ -416,50 +447,58 @@
     (when (eq window *current-window*) (maybe-recenter-window window))
     hunk))
 
-(defun baba (stream echo-stream)
-  (let* ((window (hi::internal-make-window))
-         (hunk (make-instance 'clim-hunk :stream stream))
-         (echo-window (hi::internal-make-window))
-         (echo-hunk (make-instance 'clim-hunk :stream echo-stream))
+(defun baba (stream echo-stream another-stream)
+  (let* (
          (device (make-instance 'clim-device))
          (buffer *current-buffer*)
          (start (buffer-start-mark buffer))
          (first (cons dummy-line the-sentinel)) )
     (declare (ignorable start first))
-    (setf (slot-value hunk 'ts) (clim:make-text-style :fixed :roman :normal))
-    #+NIL
-    (setf (slot-value hunk 'ts) (clim:make-device-font-text-style
-                                 (clim:port stream)
-                                 "-*-lucidatypewriter-medium-r-*-*-*-120-*-*-*-*-iso8859-1"))
-    (setf (slot-value hunk 'ts) (clim:make-text-style :sans-serif :roman :normal))
-    (setf (slot-value hunk 'cw) (clim:text-style-width (slot-value hunk 'ts)
-                                                           (clim-hunk-stream hunk)))
-    (setf (slot-value hunk 'ch) (+ 2 (clim:text-style-height (slot-value hunk 'ts)
-                                                             (clim-hunk-stream hunk))))
-    (setf (slot-value echo-hunk 'ts) (clim:make-text-style :fix :roman 12))
-    (setf (slot-value echo-hunk 'cw) (clim:text-style-width (slot-value echo-hunk 'ts)
-                                                       (clim-hunk-stream echo-hunk)))
-    (setf (slot-value echo-hunk 'ch) (+ 2 (clim:text-style-height (slot-value echo-hunk 'ts)
-                                                             (clim-hunk-stream echo-hunk))))
-    
+    (setf (buffer-windows buffer) nil
+          (buffer-windows *echo-area-buffer*) nil)
     (setf
      (device-name device) "CLIM"
-     (device-bottom-window-base device) nil
-     (device-hunks device) (list hunk))
-
-    (baba-aux device window hunk buffer
-              ;;(floor 800 (slot-value hunk 'cw))
-              120
-              (floor 500 (slot-value hunk 'ch)))
-    (baba-aux device echo-window echo-hunk *echo-area-buffer* 80 2)
-    (setf *echo-area-window* echo-window)
-    
-    (setf *current-window* window) ))
+     (device-bottom-window-base device) nil)
+    (let* ((window (hi::internal-make-window))
+           (hunk (make-instance 'clim-hunk :stream stream)))
+      (baba-aux device window hunk buffer)
+      (setf *current-window* window)
+      (push window (slot-value device 'windows))
+      (setf (device-hunks device) (list hunk)) )
+    (when another-stream
+      (let* ((window (hi::internal-make-window))
+             (hunk (make-instance 'clim-hunk :stream another-stream)))
+        (baba-aux device window hunk buffer)
+        (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.
+      )
+    ;;
+    ))
 
-(defun baba-aux (device window hunk buffer width height)
+(defun baba-aux (device window hunk buffer)
+  (setf (slot-value (clim-hunk-stream hunk) 'hunk)
+        hunk)
   (let* ((start (buffer-start-mark buffer))
-         (first (cons dummy-line the-sentinel)))
+         (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 '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)
+                         (slot-value hunk 'cw)))
+     height (max 2 (floor (- (clim:bounding-rectangle-height (clim-hunk-stream hunk))
+                             10)
+                          (slot-value hunk 'ch)))
      (device-hunk-window hunk) window
      (device-hunk-position hunk) 0
      (device-hunk-height hunk) height
@@ -467,19 +506,19 @@
      (device-hunk-previous hunk) nil
      (device-hunk-device hunk) device
 
-     (window-tick window) -1            ; The last time this window was updated.
-     (window-%buffer window) buffer     ; buffer displayed in this window.
+     (window-tick window) -1  ; The last time this window was updated.
+     (window-%buffer window) buffer ; buffer displayed in this window.
      (window-height window) height      ; Height of window in lines.
-     (window-width window) width        ; Width of the window in characters.
+     (window-width window) width  ; Width of the window in characters.
      
      (window-old-start window) (copy-mark start :temporary) ; The charpos of the first char displayed.
-     (window-first-line window) first   ; The head of the list of dis-lines.
+     (window-first-line window) first ; The head of the list of dis-lines.
      (window-last-line window) the-sentinel ; The last dis-line displayed.
      (window-first-changed window) the-sentinel ; The first changed dis-line on last update.
      (window-last-changed window) first ; The last changed dis-line.
-     (window-spare-lines window) nil    ; The head of the list of unused dis-lines
+     (window-spare-lines window) nil ; The head of the list of unused dis-lines
      
-     (window-hunk window) hunk          ; The device hunk that displays this window.
+     (window-hunk window) hunk ; The device hunk that displays this window.
 
      (window-display-start window) (copy-mark start :right-inserting) ; first character position displayed
      (window-display-end window) (copy-mark start :right-inserting) ; last character displayed
@@ -493,18 +532,21 @@
      (window-display-recentering window) nil ;
      )
 
-    ;;
-    ;; Make the dis-lines.
-    (do ((i (- height) (1+ i))
-         (res ()
-              (cons (make-window-dis-line (make-string width)) res)))
-        ((= i height) (setf (window-spare-lines window) res)))
-
-    (setf (buffer-windows buffer)
-          (list window))
+    (baba-make-dis-lines window width height)
+    
+    (push window (buffer-windows buffer))
     (push window *window-list*)
     (hi::update-window-image window)))
 
+(defun baba-make-dis-lines (window width height)
+  (do ((i (- height) (1+ i))
+       (res ()
+            (cons (make-window-dis-line (make-string width)) res)))
+      ((= i height)
+       (setf (window-spare-lines window) res))))
+
+;;;; Redisplay
+
 (defvar *tick* 0)
 
 (defmethod device-dumb-redisplay ((device clim-device) window)
@@ -529,11 +571,9 @@
                   unaltered-bits))
           #+NIL
           (setf (bitmap-hunk-start hunk) (cdr (window-first-line window))))))
-    (clim:redisplay-frame-pane clim:*application-frame* *standard-output*)
-    )
+    (clim:redisplay-frame-pane clim:*application-frame* *standard-output*))
   (clim-put-cursor (window-hunk window))
-  (force-output *standard-output*)
-  )
+  (force-output *standard-output*) )
 
 (defun clim-dumb-line-redisplay (hunk dl)
   (let* ((stream (clim-hunk-stream hunk))
@@ -576,29 +616,25 @@
                                      start (font-change-x changes) font)
                      (setf font (font-change-font changes)
                            start (font-change-x changes)
-                           changes (font-change-next 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)
+  (let ((ch (clim:text-style-height (clim:medium-text-style stream)
+                                    stream))
+        (dx (clim:stream-string-width stream string :start start :end end)))
+    (clim:draw-rectangle* stream
+                          x (1- y)
+                          (+ x dx) (+ y ch 1) :ink (hemlock-font-background font)))
   (clim:draw-text* stream string x y
                    :start start :end end
                    :align-y :top
-                   :ink (case font
-                          (1 clim:+blue4+)
-                          (3 clim:+blue4+)
-                          (2 clim:+cyan4+)
-                          (4 clim:+green4+)
-                          (5 clim:+red4+)
-                          (6 clim:+gray50+)
-                          (otherwise clim:+black+)))
+                   :ink (hemlock-font-foreground font))
   (when (= font 5)
     (let ((ch (clim:text-style-height (clim:medium-text-style stream)
                                       stream))
           (dx (clim:stream-string-width stream string :start start :end end)))
-    (clim:draw-line* stream x (+ y ch -1) (+ x dx) (+ y ch -1))))
-  )
+      (clim:draw-line* stream x (+ y ch -1) (+ x dx) (+ y ch -1)))) )
 
 (defun clim-drop-cursor (hunk)
   (with-slots (cx cy cw ch) hunk
@@ -640,48 +676,25 @@
 	(sleep .1)))
     (device-note-read-wait device nil)))
 
-
-
 ;;;
 
-#+NIL
-(defparameter mcclim-freetype::*families/faces*
-  '(
-    #||
-    ((:fix :roman) . "/usr/X11R6/lib/X11/fonts/microsoft/lucon.ttf")
-    ;;((:fix :roman) . "/usr/X11R6/lib/X11/fonts/microsoft/cour.ttf")
-    ((:fix :italic) . "/usr/X11R6/lib/X11/fonts/microsoft/couri.ttf")
-    ((:fix :bold-italic) . "/usr/X11R6/lib/X11/fonts/microsoft/courbi.ttf")
-    ((:fix :italic-bold) . "/usr/X11R6/lib/X11/fonts/microsoft/courbi.ttf")
-    ((:fix :bold) . "/usr/X11R6/lib/X11/fonts/microsoft/courbd.ttf")
-    ||#
-
-
-    ((:fix :roman) . "/usr/local/OpenOffice.org1.1.0/share/fonts/truetype/VeraMono.ttf")
-    ((:fix :roman) . "/usr/share/texmf/fonts/type1/bluesky/cm/cmtt8.pfb")
-    ((:fix :italic) . "/usr/share/texmf/fonts/type1/bluesky/cm/cmtt12.pfb")
-    ((:fix :italic-bold) . "/usr/local/OpenOffice.org1.1.0/share/fonts/truetype/VeraMoBI.ttf")
-    ((:fix :bold-italic) . "/usr/local/OpenOffice.org1.1.0/share/fonts/truetype/VeraMoBI.ttf")
-    ((:fix :bold) . "/usr/local/OpenOffice.org1.1.0/share/fonts/truetype/VeraMoBd.ttf")
-
-    ((:sans-serif :roman) . "/usr/share/texmf/fonts/type1/bluesky/cm/cmss12.pfb")
-    ((:sans-serif :italic) . "/usr/share/texmf/fonts/type1/bluesky/cm/cmssi12.pfb")
-    ((:sans-serif :bold-italic) . "/usr/share/texmf/fonts/type1/bluesky/cm/cmssi12.pfb")
-    ((:sans-serif :italic-bold) . "/usr/share/texmf/fonts/type1/bluesky/cm/cmssi12.pfb")
-    ((:sans-serif :bold) . "/usr/share/texmf/fonts/type1/bluesky/cm/cmssbx10.pfb")
-    
-    ((:serif :roman) . "/usr/X11R6/lib/X11/fonts/microsoft/verdana.ttf")
-    ((:serif :italic) . "/usr/X11R6/lib/X11/fonts/microsoft/verdanai.ttf")
-    ((:serif :bold-italic) . "/usr/X11R6/lib/X11/fonts/microsoft/verdanaz.ttf")
-    ((:serif :italic-bold) . "/usr/X11R6/lib/X11/fonts/microsoft/verdanaz.ttf")
-    ((:serif :bold) . "/usr/X11R6/lib/X11/fonts/microsoft/verdanab.ttf")))
-
-
-
-
-
-
-
-
-
+(defun hemlock-font-foreground (font)
+  (case font
+    (1 clim:+blue4+)
+    (3 clim:+black+)
+    (2 clim:+cyan4+)
+    (4 clim:+green4+)
+    (5 clim:+red4+)
+    (6 clim:+gray50+)
+    (otherwise clim:+black+)))
+
+(defun hemlock-font-background (font)
+  (case font
+    (3 (clim:make-rgb-color 1 .9 .8))
+    (otherwise clim:+white+)))
+
+;; $Log: foo.lisp,v $
+;; Revision 1.4  2004/11/21 01:03:51  gbaumann
+;; Basic support for c-x 1 and c-x 2.
+;;
 




From gbaumann at common-lisp.net  Mon Nov 22 21:38:08 2004
From: gbaumann at common-lisp.net (Gilbert Baumann)
Date: Mon, 22 Nov 2004 22:38:08 +0100
Subject: [Phemlock-cvs] CVS update: phemlock/hemlock.asd 
Message-ID: <E1CWLsu-0001Rp-00@common-lisp.net>

Update of /project/phemlock/cvsroot/phemlock
In directory common-lisp.net:/tmp/cvs-serv5555

Modified Files:
	hemlock.asd 
Log Message:
removed #-CMU before (asdf:defsystem ...) and "src" in the toplevel
:directory option. Noted by Jochen Schmidt.

Date: Mon Nov 22 22:38:07 2004
Author: gbaumann

Index: phemlock/hemlock.asd
diff -u phemlock/hemlock.asd:1.3 phemlock/hemlock.asd:1.4
--- phemlock/hemlock.asd:1.3	Sat Oct 16 21:28:19 2004
+++ phemlock/hemlock.asd	Mon Nov 22 22:38:06 2004
@@ -27,12 +27,10 @@
                                (string-downcase (lisp-implementation-type))))
                  :defaults *hemlock-base-directory*))
 
-#-CMU
 (asdf:defsystem :hemlock
      :pathname #.(make-pathname
  			:directory
- 			(append (pathname-directory *hemlock-base-directory*)
- 				(list "src"))
+                        (pathname-directory *hemlock-base-directory*)
  			:defaults *hemlock-base-directory*)
 ;;     :source-extension "lisp"
 ;;     :binary-pathname #.*binary-pathname*