Changeset 617

Timestamp:

Mar 6, 2004, 9:47:08 AM (17 years ago)

Author:

gb

Message:

Random changes; still barely functional.

Location:

trunk/ccl

Files:

• examples/cocoa-defaults.lisp (modified) (4 diffs)
• examples/cocoa-editor.lisp (modified) (14 diffs)
• examples/cocoa-listener.lisp (modified) (2 diffs)
• hemlock/src/font.lisp (modified) (2 diffs)
• hemlock/src/listener.lisp (modified) (1 diff)
• hemlock/src/rompsite.lisp (modified) (1 diff)

trunk/ccl/examples/cocoa-defaults.lisp

@@ -1 @@
-;;;-*- Mode: LISP; Package: CCL -*-
-
 ;;;-*-Mode: LISP; Package: CCL -*-
 ;;;
@@ -20 +18 @@
 
 (eval-when (:compile-toplevel :execute)
-  (use-interface-dir :cocoa))
+  (use-interface-dir :cocoa)
+  (use-interface-dir :carbon))
 
 (require "OBJC-SUPPORT")
@@ -60 +59 @@
   (record-source-file name 'variable)
   (setf (documentation name 'variable) doc)
-  (set name (set-cocoa-default name (ns-constant-string (string-downcase name)) type value doc))
+  (set name (set-cocoa-default name (ns-constant-string (string name)) type value doc))
   name)
   
@@ -76 +75 @@
       (let* ((name (cocoa-default-symbol d))
              (key (objc-constant-string-nsstringptr (cocoa-default-string d))))
-        (case (cocoa-default-type d)
-          (:int
-           (set name (send domain :integer-for-key key)))
-          (:float
-           (set name (send domain :float-for-key key)))
-          (:string
-           (let* ((nsstring (send domain :string-for-key key)))
-             (unless (%null-ptr-p nsstring)
-               (set name (lisp-string-from-nsstring nsstring))))))))))
+        (if (%null-ptr-p (send domain :object-for-key key))
+          (send domain
+                :set-object (%make-nsstring (format nil "~a" (cocoa-default-value d)))
+                :for-key key)
+          (case (cocoa-default-type d)
+            (:int
+             (set name (send domain :integer-for-key key)))
+            (:float
+             (set name (send domain :float-for-key key)))
+            (:string
+             (let* ((nsstring (send domain :string-for-key key)))
+               (unless (%null-ptr-p nsstring)
+                 (set name (lisp-string-from-nsstring nsstring)))))))))
+    (send domain 'synchronize)
+    (send domain 'dictionary-representation)))
 
-(defun register-cocoa-defaults ()
-  (let* ((domain (send (@class "NSUserDefaults") 'standard-user-defaults))
-         (defaults (cocoa-defaults))
-         (dict (make-objc-instance 'ns:ns-mutable-dictionary
-                                   :with-capacity (length defaults))))
-    (dolist (d defaults)
-      (let* ((key (objc-constant-string-nsstringptr (cocoa-default-string d)))
-             (value (%make-nsstring (format nil "~a" (cocoa-default-value d)))))
-        (send dict :set-value value :for-key key)))
-    (break "dict = ~s" dict)
-    (send domain :register-defaults dict)
-    (send domain 'synchronize)))
+
   
                                    

trunk/ccl/examples/cocoa-editor.lisp

@@ -10 +10 @@
 (eval-when (:compile-toplevel :execute)
   (use-interface-dir :cocoa))
+
+(def-cocoa-default *editor-rows* :int 24)
+(def-cocoa-default *editor-columns* :int 80)
+
+;;; At runtime, this'll be a vector of character attribute dictionaries.
+(defloadvar *styles* ())
+
+(defun make-editor-style-map ()
+  (let* ((font-name *default-font-name*)
+         (font-size *default-font-size*)
+         (fonts (vector (default-font :name font-name :size font-size
+                                      :attributes ())
+                        (default-font :name font-name :size font-size
+                                      :attributes '(:bold))
+                        (default-font  :name font-name :size font-size
+                                      :attributes '(:italic))
+                        (default-font :name font-name :size font-size
+                                      :attributes '(:bold :italic))))
+         (color-class (find-class 'ns:ns-color))
+         (colors (vector (send color-class 'black-color)
+                         (send color-class 'white-color)
+                         (send color-class 'dark-gray-color)
+                         (send color-class 'light-gray-color)
+                         (send color-class 'red-color)
+                         (send color-class 'blue-color)
+                         (send color-class 'green-color)
+                         (send color-class 'yellow-color)))
+         (styles (make-array (the fixnum (* (length fonts) (length colors)))))
+         (s 0))
+    (declare (dynamic-extent fonts colors))
+    (dotimes (c (length colors))
+      (dotimes (f (length fonts))
+        (setf (svref styles s) (create-text-attributes :font (svref fonts f)
+                                                       :color (svref colors c)))
+        (incf s)))
+    (setq *styles* styles)))
 
 (defun make-hemlock-buffer (&rest args)
@@ -88 +124 @@
   workline-offset                       ; cached offset of workline
   workline-length                       ; length of cached workline
+  workline-start-font-index             ; current font index at start of worklin
   )
 
@@ -103 +140 @@
           (buffer-cache-workline-offset d) 0
           (buffer-cache-workline d) workline
-          (buffer-cache-workline-length d) (hemlock::line-length workline))
+          (buffer-cache-workline-length d) (hemlock::line-length workline)
+          (buffer-cache-workline-start-font-index d) 0)
     d))
 
@@ -246 +284 @@
 ;;; Lisp-text-storage objects
 (defclass lisp-text-storage (ns:ns-text-storage)
-    ((string :foreign-type :id)
-     (defaultattrs :foreign-type :id))
+    ((string :foreign-type :id))
   (:metaclass ns:+ns-object))
 
@@ -257 +294 @@
 (define-objc-method ((:id :init-with-string s) lisp-text-storage)
   (let* ((newself (send-super 'init)))
-    (setf (slot-value newself 'string) s
-          (slot-value newself 'defaultattrs) (create-text-attributes))
+    (setf (slot-value newself 'string) s)
     newself))
 
@@ -285 +321 @@
       (setf (pref rangeptr :<NSR>ange.location) 0
             (pref rangeptr :<NSR>ange.length) len))
-    (slot-value self 'defaultattrs)))
+    (svref *styles* 0)))
 
 ;;; The range's origin should probably be the buffer's point; if
@@ -581 +617 @@
 
 
-(defun make-scrolling-text-view-for-textstorage (textstorage x y width height)
+(defun make-scrolling-text-view-for-textstorage (textstorage x y width height tracks-width)
   (slet ((contentrect (ns-make-rect x y width height)))
     (let* ((scrollview (send (make-objc-instance
@@ -623 +659 @@
               (send tv :set-vertically-resizable t) 
               (send tv :set-autoresizing-mask #$NSViewWidthSizable)
-              (send container :set-width-tracks-text-view nil)
+              (send container :set-width-tracks-text-view tracks-width)
               (send container :set-height-tracks-text-view nil)
               (send scrollview :set-document-view tv)         
               (values tv scrollview))))))))
 
-(defun make-scrolling-textview-for-pane (pane textstorage)
+(defun make-scrolling-textview-for-pane (pane textstorage track-widht)
   (slet ((contentrect (send (send pane 'content-view) 'frame)))
     (multiple-value-bind (tv scrollview)
@@ -636 +672 @@
          (pref contentrect :<NSR>ect.origin.y)
          (pref contentrect :<NSR>ect.size.width)
-         (pref contentrect :<NSR>ect.size.height))
+         (pref contentrect :<NSR>ect.size.height)
+         track-widht)
       (send pane :set-content-view scrollview)
       (setf (slot-value pane 'scroll-view) scrollview
@@ -747 +784 @@
                                         
                                       
-(defun textpane-for-textstorage (ts)
+(defun textpane-for-textstorage (ts ncols nrows container-tracks-text-view-width)
   (let* ((pane (nth-value
                 1
                 (new-hemlock-document-window :activate nil)))
-         (tv (make-scrolling-textview-for-pane pane ts)))
+         (tv (make-scrolling-textview-for-pane pane ts container-tracks-text-view-width)))
     (multiple-value-bind (height width)
         (size-of-char-in-font (default-font))
-      (size-textview-containers tv height width 24 80))
+      (size-textview-containers tv height width nrows ncols))
     pane))
 
@@ -841 +878 @@
 
 ;;; This function must run in the main event thread.
-(defun %hemlock-frame-for-textstorage (ts title activate)
-  (let* ((pane (textpane-for-textstorage ts))
-         (w (send pane 'window)))
-    (when title (send w :set-title (%make-nsstring title)))
-    (when activate (activate-window w))
-    w))
-
-(defun hemlock-frame-for-textstorage (ts title activate)
+(defun %hemlock-frame-for-textstorage (ts ncols nrows container-tracks-text-view-width)
+  (let* ((pane (textpane-for-textstorage ts ncols nrows container-tracks-text-view-width)))
+    (send pane 'window)))
+
+
+(defun hemlock-frame-for-textstorage (ts ncols nrows container-tracks-text-view-width)
   (process-interrupt *cocoa-event-process*
                      #'%hemlock-frame-for-textstorage
-                     ts title activate))
+                     ts  ncols nrows container-tracks-text-view-width))
 
 
@@ -911 +946 @@
             (decf pos n))
           #+debug
-          (format t "~&pos = ~d, n = ~d" pos n)
+          (format t "~&insert: pos = ~d, n = ~d" pos n)
           (let* ((display (hemlock-buffer-string-cache (send textstorage 'string))))
             (reset-buffer-cache display) 
@@ -930 +965 @@
           (force-output)
           (send textstorage
-                :edited #$NSTextStorageEditedAttributes
+                :edited #$NSTextStorageEditedCharacters
                 :range (ns-make-range pos n)
                 :change-in-length (- n))
@@ -1090 +1125 @@
   (let* ((controller (make-objc-instance
                       'lisp-editor-window-controller
-                      :with-window (%hemlock-frame-for-textstorage
-                                    (slot-value self 'textstorage) nil nil))))
+                      :with-window (%hemlock-frame-for-textstorage 
+                                    (slot-value self 'textstorage)
+                                    *editor-columns*
+                                    *editor-rows*
+                                    nil))))
     (send self :add-window-controller controller)
     (send controller 'release)))         

trunk/ccl/examples/cocoa-listener.lisp

@@ -6 +6 @@
   (require "COCOA-EDITOR")
   (require "PTY"))
+
+(def-cocoa-default *listener-rows* :int 16)
+(def-cocoa-default *listener-columns* :int 80)
 
 ;;; Setup the server end of a pty pair.
@@ -225 +228 @@
 
 (define-objc-method ((:void make-window-controllers) lisp-listener-document)
-  (let* ((controller (make-objc-instance
+  (let* ((textstorage (slot-value self 'textstorage))
+         (controller (make-objc-instance
                       'lisp-listener-window-controller
                       :with-window (%hemlock-frame-for-textstorage
-                                    (slot-value self 'textstorage) nil nil)))
+                                    textstorage
+                                    *listener-columns*
+                                    *listener-rows*
+                                    t)))
          (listener-name (hi::buffer-name (hemlock-document-buffer self))))
     (send self :add-window-controller controller)

trunk/ccl/hemlock/src/font.lisp

@@ -93 +93 @@
 ;;;; Referencing and setting font ids.
 
+#+clx
+(progn
 (defun window-font (window font)
   "Returns a font id for window and font."
@@ -119 +121 @@
       (setf (bitmap-hunk-trashed (window-hunk w)) :font-change)))
   (setf (svref (font-family-map *default-font-family*) font) font-object))
+)

trunk/ccl/hemlock/src/listener.lisp

@@ -325 +325 @@
          (length (ring-length ring))
          (p (or p 1)))
-    (when (or (mark< point mark) (zerop length)) (editor-error))
+    (when (or (mark< point mark) (zerop length)) (editor-error "Can't get command history"))
     (cond
      ((eq (last-command-type) :interactive-history)

trunk/ccl/hemlock/src/rompsite.lisp

@@ -261 +261 @@
   "The number of possible fonts in a font-map.")
 #-clx
-(defconstant font-map-size 16)
+(defconstant font-map-size 32)
 
 ;;; SETUP-FONT-FAMILY sets *default-font-family*, opening the three font names