Changeset 6724
- Timestamp:
- Jun 14, 2007, 12:36:46 AM (17 years ago)
- File:
-
- 1 edited
-
branches/ide-1.0/ccl/examples/cocoa-editor.lisp (modified) (18 diffs)
Legend:
- Unmodified
- Added
- Removed
-
branches/ide-1.0/ccl/examples/cocoa-editor.lisp
r6718 r6724 28 28 (def-cocoa-default *editor-columns* :int 80 "Initial width of editor windows, in characters") 29 29 30 ;;; Background color components: red, blue, green, alpha. 31 ;;; All should be single-floats between 0.0f0 and 1.0f0, inclusive. 32 (def-cocoa-default *editor-background-red-component* :float 1.0f0 "Red component of editor background color. Should be a float between 0.0 and 1.0, inclusive.") 33 (def-cocoa-default *editor-background-green-component* :float 1.0f0 "Green component of editor background color. Should be a float between 0.0 and 1.0, inclusive.") 34 (def-cocoa-default *editor-background-blue-component* :float 1.0f0 "Blue component of editor background color. Should be a float between 0.0 and 1.0, inclusive.") 35 (def-cocoa-default *editor-background-alpha-component* :float 1.0f0 "Alpha component of editor background color. Should be a float between 0.0 and 1.0, inclusive.") 36 37 ;;; At runtime, this'll be a vector of character attribute dictionaries. 38 (defloadvar *styles* ()) 30 (def-cocoa-default *editor-background-color* :color (#/whiteColor ns:ns-color) "Editor background color") 31 39 32 40 33 (defun make-editor-style-map () … … 57 50 (#/greenColor color-class) 58 51 (#/yellowColor color-class))) 59 (styles (make-array (the fixnum (* 4 (length colors))))) 52 (styles (make-instance 'ns:ns-mutable-array 53 :with-capacity (the fixnum (* 4 (length colors))))) 60 54 (bold-stroke-width -10.0f0) 61 55 (fonts (vector font (or bold-font font) (or oblique-font font) (or bold-oblique-font font))) … … 66 60 (dotimes (i 4) 67 61 (let* ((mask (logand i 3))) 68 (setf (svref styles s) (create-text-attributes :font (svref fonts mask) 69 :color (svref colors c) 70 :obliqueness 71 (if (logbitp 1 i) 72 (unless (svref real-fonts mask) 73 0.15f0)) 74 :stroke-width 75 (if (logbitp 0 i) 76 (unless (svref real-fonts mask) 77 bold-stroke-width))))) 62 (#/addObject: styles 63 (create-text-attributes :font (svref fonts mask) 64 :color (svref colors c) 65 :obliqueness 66 (if (logbitp 1 i) 67 (unless (svref real-fonts mask) 68 0.15f0)) 69 :stroke-width 70 (if (logbitp 0 i) 71 (unless (svref real-fonts mask) 72 bold-stroke-width))))) 78 73 (incf s))) 79 ( setq *styles*styles)))74 (#/retain styles))) 80 75 81 76 (defun make-hemlock-buffer (&rest args) … … 374 369 (edit-count :foreign-type :int) 375 370 (append-edits :foreign-type :int) 376 (cache :foreign-type :id)) 371 (cache :foreign-type :id) 372 (styles :foreign-type :id)) 377 373 (:metaclass ns:+ns-object)) 378 374 … … 465 461 466 462 (objc:defmethod #/hemlockString ((self hemlock-text-storage)) 467 (slot-value self 'hemlock-string)) 463 (slot-value self 'hemlock-string)) 464 465 (objc:defmethod #/styles ((self hemlock-text-storage)) 466 (slot-value self 'styles)) 468 467 469 468 (objc:defmethod #/initWithString: ((self hemlock-text-storage) s) 470 469 (setq s (%inc-ptr s 0)) 471 470 (let* ((newself (#/init self)) 471 (styles (make-editor-style-map)) 472 472 (cache (#/retain (make-instance ns:ns-mutable-attributed-string 473 473 :with-string s 474 :attributes ( svref *styles*0)))))474 :attributes (#/objectAtIndex: styles 0))))) 475 475 (declare (type hemlock-text-storage newself)) 476 (setf (slot-value newself 'styles) styles) 476 477 (setf (slot-value newself 'hemlock-string) s) 477 478 (setf (slot-value newself 'cache) cache) … … 481 482 ;;; Should generally only be called after open/revert. 482 483 (objc:defmethod (#/updateCache :void) ((self hemlock-text-storage)) 483 (with-slots (hemlock-string cache ) self484 (with-slots (hemlock-string cache styles) self 484 485 (#/replaceCharactersInRange:withString: cache (ns:make-ns-range 0 (#/length cache)) hemlock-string) 485 (#/setAttributes:range: cache ( svref *styles*0) (ns:make-ns-range 0 (#/length cache)))))486 (#/setAttributes:range: cache (#/objectAtIndex: styles 0) (ns:make-ns-range 0 (#/length cache))))) 486 487 487 488 ;;; This is the only thing that's actually called to create a … … 502 503 #+debug 503 504 (#_NSLog #@"Attributes at index: %d storage %@" :unsigned index :id self) 504 (with-slots (cache ) self505 (with-slots (cache styles) self 505 506 (let* ((attrs (#/attributesAtIndex:effectiveRange: cache index rangeptr))) 506 507 (when (eql 0 (#/count attrs)) … … 509 510 (#/attributesAtIndex:longestEffectiveRange:inRange: 510 511 cache index r (ns:make-ns-range 0 (#/length cache))) 511 (setq attrs ( svref *styles*0))512 (setq attrs (#/objectAtIndex: styles 0)) 512 513 (#/setAttributes:range: cache attrs r))) 513 514 attrs))) … … 539 540 (when textstorage 540 541 (#/endEditing textstorage) 541 (for-each-textview-using-storage textstorage (lambda (tv) 542 (hi::disable-self-insert (hemlock-frame-event-queue (#/window tv))))) 542 (for-each-textview-using-storage 543 textstorage 544 (lambda (tv) 545 (hi::disable-self-insert 546 (hemlock-frame-event-queue (#/window tv))))) 543 547 (#/ensureSelectionVisible textstorage))))) 544 548 … … 579 583 580 584 (defun close-hemlock-textstorage (ts) 585 (declare (type hemlock-text-storage ts)) 586 (with-slots (styles) ts 587 (#/release styles) 588 (setq styles +null-ptr+)) 581 589 (let* ((hemlock-string (slot-value ts 'hemlock-string))) 582 590 (setf (slot-value ts 'hemlock-string) +null-ptr+) 591 583 592 (unless (%null-ptr-p hemlock-string) 584 593 (let* ((cache (hemlock-buffer-string-cache hemlock-string)) … … 626 635 (:metaclass ns:+ns-object)) 627 636 637 (objc:defmethod (#/changeColor: :void) ((self hemlock-textstorage-text-view) 638 sender) 639 (#_NSLog #@"Change color to = %@" :id (#/color sender))) 628 640 629 641 (def-cocoa-default *layout-text-in-background* :int 1 "When non-zero, do text layout when idle.") … … 1153 1165 (#/setAutoresizingMask: tv #$NSViewWidthSizable) 1154 1166 (#/setBackgroundColor: tv color) 1155 (#/setTypingAttributes: tv ( aref *styles*style))1167 (#/setTypingAttributes: tv (#/objectAtIndex: (#/styles textstorage) style)) 1156 1168 (#/setSmartInsertDeleteEnabled: tv nil) 1157 1169 (#/setAllowsUndo: tv nil) ; don't want NSTextView undo 1158 1170 (#/setUsesFindPanel: tv t) 1171 (#/setUsesFontPanel: tv t) 1159 1172 (#/setWidthTracksTextView: container tracks-width) 1160 1173 (#/setHeightTracksTextView: container nil) … … 1594 1607 (let* ((document (hi::buffer-document buffer)) 1595 1608 (textstorage (if document (slot-value document 'textstorage))) 1609 (styles (#/styles textstorage)) 1596 1610 (cache (#/cache textstorage)) 1597 1611 (pos (mark-absolute-position (hi::region-start region))) 1598 1612 (n (- (mark-absolute-position (hi::region-end region)) pos))) 1599 1613 #+debug 1600 (#_NSLog #@"Setting font attributes for %d/%d to %@" :int pos :int n :id ( svref *styles*font))1601 (#/setAttributes:range: cache ( svref *styles*font) (ns:make-ns-range pos n))1614 (#_NSLog #@"Setting font attributes for %d/%d to %@" :int pos :int n :id (#/objectAtIndex: styles font)) 1615 (#/setAttributes:range: cache (#/objectAtIndex: styles font) (ns:make-ns-range pos n)) 1602 1616 (perform-edit-change-notification textstorage 1603 1617 (@selector #/noteAttrChange:) … … 1607 1621 (defun buffer-active-font (buffer) 1608 1622 (let* ((style 0) 1609 (region (hi::buffer-active-font-region buffer))) 1623 (region (hi::buffer-active-font-region buffer)) 1624 (textstorage (slot-value (hi::buffer-document buffer) 'textstorage)) 1625 (styles (#/styles textstorage))) 1610 1626 (when region 1611 1627 (let* ((start (hi::region-end region))) 1612 1628 (setq style (hi::font-mark-font start)))) 1613 ( svref *styles*style)))1629 (#/objectAtIndex: styles style))) 1614 1630 1615 1631 (defun hi::buffer-note-insertion (buffer mark n) … … 1802 1818 1803 1819 (defmethod textview-background-color ((doc hemlock-editor-document)) 1804 (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 1805 (float *editor-background-red-component* 1806 +cgfloat-zero+) 1807 (float *editor-background-green-component* +cgfloat-zero+) 1808 (float *editor-background-blue-component* +cgfloat-zero+) 1809 (float *editor-background-alpha-component* +cgfloat-zero+))) 1820 *editor-background-color*) 1810 1821 1811 1822 … … 1984 1995 (buffer (hemlock-document-buffer self))) 1985 1996 (case (when buffer (hi::buffer-line-termination buffer)) 1986 (:cp/m (setq string (#/stringByReplacingOccurrencesOfString:withString: 1987 string *ns-lf-string* *ns-crlf-string*))) 1988 (:macos (setq string (#/stringByReplacingOccurrencesOfString:withString: 1989 string *ns-lf-string* *ns-cr-string*)))) 1997 (:cp/m (unless (typep string 'ns:ns-mutable-string) 1998 (setq string (make-instance 'ns:ns-mutable-string :with string string)) 1999 (#/replaceOccurrencesOfString:withString:options:range: 2000 string *ns-lf-string* *ns-crlf-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string))))) 2001 (:macos (setq string (if (typep string 'ns:ns-mutable-string) 2002 string 2003 (make-instance 'ns:ns-mutable-string :with string string))) 2004 (#/replaceOccurrencesOfString:withString:options:range: 2005 string *ns-lf-string* *ns-cr-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string))))) 1990 2006 (when (#/writeToURL:atomically:encoding:error: 1991 2007 string url t encoding error) … … 2193 2209 (defun initialize-user-interface () 2194 2210 (#/sharedDocumentController hemlock-document-controller) 2195 (#/sharedPanel preferences-panel) 2196 (update-cocoa-defaults) 2211 (#/sharedPanel lisp-preferences-panel) 2197 2212 (make-editor-style-map)) 2198 2213 … … 2271 2286 (unless (%null-ptr-p string) 2272 2287 (unless (zerop (ns:ns-range-length (#/rangeOfString: string *ns-cr-string*))) 2273 (setq string (#/stringByReplacingOccurrencesOfString:withString: string *ns-cr-string* *ns-lf-string*))) 2288 (unless (typep string 'ns:ns-mutable-string) 2289 (setq string (make-instance 'ns:ns-mutable-string :with-string string))) 2290 (#/replaceOccurrencesOfString:withString:options:range: 2291 string *ns-cr-string* *ns-lf-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string)))) 2274 2292 (let* ((textstorage (#/textStorage self)) 2275 2293 (selectedrange (#/selectedRange self)))
Note:
See TracChangeset
for help on using the changeset viewer.
