Changeset 793
- Timestamp:
- Apr 30, 2004, 5:50:19 PM (21 years ago)
- Location:
- trunk/ccl/examples
- Files:
-
- 2 edited
-
cocoa-editor.lisp (modified) (18 diffs)
-
cocoa-listener.lisp (modified) (4 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/ccl/examples/cocoa-editor.lisp
r790 r793 27 27 (let* ((font-name *default-font-name*) 28 28 (font-size *default-font-size*) 29 (fonts (vector (default-font :name font-name :size font-size 30 :attributes ()) 31 (default-font :name font-name :size font-size 32 :attributes '(:bold)) 33 (default-font :name font-name :size font-size 34 :attributes '(:italic)) 35 (default-font :name font-name :size font-size 36 :attributes '(:bold :italic)))) 29 (font (default-font :name font-name :size font-size)) 37 30 (color-class (find-class 'ns:ns-color)) 38 31 (colors (vector (send color-class 'black-color) … … 44 37 (send color-class 'green-color) 45 38 (send color-class 'yellow-color))) 46 (styles (make-array (the fixnum (* (length fonts) (length colors))))) 39 (styles (make-array (the fixnum (* 4 (length colors))))) 40 (bold-stroke-width font-size) 47 41 (s 0)) 48 42 (declare (dynamic-extent fonts colors)) 49 43 (dotimes (c (length colors)) 50 (dotimes (f (length fonts)) 51 (setf (svref styles s) (create-text-attributes :font (svref fonts f) 52 :color (svref colors c))) 44 (dotimes (i 4) 45 (setf (svref styles s) (create-text-attributes :font font 46 :color (svref colors c) 47 :obliqueness 48 (if (logbitp 1 i) 49 0.15f0) 50 :stroke-width 51 (if (logbitp 0 i) 52 bold-stroke-width))) 53 53 (incf s))) 54 54 (setq *styles* styles))) … … 359 359 :change-in-length 0))) 360 360 361 (define-objc-method ((:void :note-attr-change params) hemlock-text-storage) 362 (let* ((pos (send (send params :object-at-index 0) 'int-value)) 363 (n (send (send params :object-at-index 1) 'int-value))) 364 #+debug (#_NSLog #@"attribute-change at %d/%d" :int pos :int n) 365 (send self 366 :edited #$NSTextStorageEditedAttributes 367 :range (ns-make-range pos n) 368 :change-in-length 0))) 369 361 370 (define-objc-method ((:void begin-editing) hemlock-text-storage) 362 371 #+debug … … 400 409 buffer)))) 401 410 402 ;;; So far, we're ignoring Hemlock's font-marks, so all characters in403 ;;; the buffer are presumed to have default attributes.404 411 (define-objc-method ((:id :attributes-at-index (:unsigned index) 405 412 :effective-range ((* :<NSR>ange) rangeptr)) 406 413 hemlock-text-storage) 407 (declare (ignorable index))408 414 (let* ((buffer-cache (hemlock-buffer-string-cache (slot-value self 'string))) 409 (len (buffer-cache-buflen buffer-cache))) 410 (unless (%null-ptr-p rangeptr) 411 (setf (pref rangeptr :<NSR>ange.location) 0 412 (pref rangeptr :<NSR>ange.length) len)) 413 (svref *styles* 0))) 415 (buffer (buffer-cache-buffer buffer-cache)) 416 (hi::*buffer-gap-context* (hi::buffer-gap-context buffer))) 417 (update-line-cache-for-index buffer-cache index) 418 (multiple-value-bind (start len style) 419 (ccl::do-dll-nodes (node 420 (hi::buffer-font-regions buffer) 421 (values 0 (buffer-cache-buflen buffer-cache) 0)) 422 (let* ((region (hi::font-region-node-region node)) 423 (start (hi::region-start region)) 424 (end (hi::region-end region)) 425 (startpos (mark-absolute-position start)) 426 (endpos (mark-absolute-position end))) 427 (when (and (>= index startpos) 428 (< index endpos)) 429 (return (values startpos 430 (- endpos startpos) 431 (hi::font-mark-font start)))))) 432 #+debug 433 (#_NSLog #@"Start = %d, len = %d, style = %d" 434 :int start :int len :int style) 435 (unless (%null-ptr-p rangeptr) 436 (setf (pref rangeptr :<NSR>ange.location) start 437 (pref rangeptr :<NSR>ange.length) len)) 438 (svref *styles* style)))) 414 439 415 440 (define-objc-method ((:void :replace-characters-in-range (:<NSR>ange r) … … 510 535 (define-objc-method ((:void :set-background-color color) 511 536 hemlock-textstorage-text-view) 512 (let* ((dict (text-view-blink-color self))) 513 (when (%null-ptr-p dict) 514 (setq dict (setf (text-view-blink-color self) 515 (make-objc-instance 'ns:ns-mutable-dictionary 516 :with-capacity 1)))) 517 (send dict :set-value color :for-key #@"NSColor") 518 (send-super :set-background-color color))) 537 (setf (text-view-blink-color self) color) 538 (send-super :set-background-color color)) 519 539 520 540 ;;; Maybe cause 1 character in the textview to blink (by setting/clearing a … … 527 547 (unless (eql #$NO (text-view-blink-enabled self)) 528 548 (let* ((layout (send self 'layout-manager)) 549 (container (send self 'text-container)) 529 550 (blink-color (text-view-blink-color self))) 530 551 ;; We toggle the blinked character "off" by setting its … … 532 553 ;; The blinked character should be "on" whenever the insertion 533 554 ;; point is drawn as "off" 534 (slet ((blink-range (ns-make-range (text-view-blink-location self) 1))) 555 (slet ((glyph-range 556 (send layout 557 :glyph-range-for-character-range 558 (ns-make-range (text-view-blink-location self) 1) 559 :actual-character-range (%null-ptr)))) 535 560 #+debug (#_NSLog #@"Flag = %d" :<BOOL> (if flag #$YES #$NO)) 536 561 (if flag 562 (slet ((rect (send layout 563 :bounding-rect-for-glyph-range glyph-range 564 :in-text-container container))) 565 (send blink-color 'set) 566 (#_NSRectFill rect)) 537 567 (send layout 538 :add-temporary-attributes blink-color 539 :for-character-range blink-range) 540 (send layout 541 :remove-temporary-attribute #@"NSColor" 542 :for-character-range blink-range))))) 568 :draw-glyphs-for-glyph-range glyph-range 569 :at-point (send self 'text-container-origin))) 570 ))) 543 571 (send-super :draw-insertion-point-in-rect r 544 572 :color color … … 548 576 (when (eql (text-view-blink-enabled self) #$YES) 549 577 (setf (text-view-blink-enabled self) #$NO) 550 (send (send self 'layout-manager) 551 :remove-temporary-attribute #@"NSColor" 552 :for-character-range (ns-make-range (text-view-blink-location self) 553 1)))) 578 (let* ((layout (send self 'layout-manager))) 579 (slet ((glyph-range (send layout 580 :glyph-range-for-character-range 581 (ns-make-range (text-view-blink-location self) 582 1) 583 :actual-character-range (%null-ptr)))) 584 (send layout 585 :draw-glyphs-for-glyph-range glyph-range 586 :at-point (send self 'text-container-origin)))))) 554 587 555 588 (defmethod update-blink ((self hemlock-textstorage-text-view)) … … 895 928 (send hscroll :set-frame scrollbar-frame) 896 929 (send modeline :set-frame modeline-frame))))))) 930 931 ;;; We want to constrain the scrolling that happens under program control, 932 ;;; so that the clipview is always scrolled in character-sized increments. 933 #+doesnt-work-yet 934 (define-objc-method ((:void :scroll-clip-view clip-view :to-point (:<NSP>oint p)) 935 modeline-scroll-view) 936 #+debug 937 (#_NSLog #@"Scrolling to point %@" :id (#_NSStringFromPoint p)) 938 939 (let* ((char-height (send self 'vertical-line-scroll))) 940 (slet ((proposed (ns-make-point (pref p :<NSP>oint.x) 941 (* char-height 942 (round (pref p :<NSP>oint.y) 943 char-height))))) 944 #+debug 945 (#_NSLog #@" Proposed point = %@" :id 946 (#_NSStringFromPoint proposed))) 947 (send-super :scroll-clip-view clip-view 948 :to-point p #+nil (ns-make-point (pref p :<NSP>oint.x) 949 (* char-height 950 (ffloor (pref p :<NSP>oint.y) 951 char-height)))))) 952 897 953 898 954 … … 1264 1320 (nsstring-to-buffer nsstring buffer))) 1265 1321 1322 (defun %nsstring-to-mark (nsstring mark) 1323 "returns external-format of string" 1324 (let* ((string-len (send nsstring 'length)) 1325 (line-start 0) 1326 (first-line-terminator ()) 1327 (first-line (hi::mark-line mark)) 1328 (previous first-line) 1329 (buffer (hi::line-%buffer first-line)) 1330 (hi::*buffer-gap-context* 1331 (or 1332 (hi::buffer-gap-context buffer) 1333 (setf (hi::buffer-gap-context buffer) 1334 (hi::make-buffer-gap-context))))) 1335 (slet ((remaining-range (ns-make-range 0 1))) 1336 (rlet ((line-end-index :unsigned) 1337 (contents-end-index :unsigned)) 1338 (do* ((number (+ (hi::line-number first-line) hi::line-increment) 1339 (+ number hi::line-increment))) 1340 ((= line-start string-len) 1341 (let* ((line (hi::mark-line mark))) 1342 (hi::insert-string mark (make-string 0)) 1343 (setf (hi::line-next previous) line 1344 (hi::line-previous line) previous)) 1345 nil) 1346 (setf (pref remaining-range :<NSR>ange.location) line-start) 1347 (send nsstring 1348 :get-line-start (%null-ptr) 1349 :end line-end-index 1350 :contents-end contents-end-index 1351 :for-range remaining-range) 1352 (let* ((contents-end (pref contents-end-index :unsigned)) 1353 (line-end (pref line-end-index :unsigned)) 1354 (chars (make-string (- contents-end line-start)))) 1355 (do* ((i line-start (1+ i)) 1356 (j 0 (1+ j))) 1357 ((= i contents-end)) 1358 (setf (schar chars j) (code-char (send nsstring :character-at-index i)))) 1359 (unless first-line-terminator 1360 (let* ((terminator (code-char 1361 (send nsstring :character-at-index 1362 contents-end)))) 1363 (setq first-line-terminator 1364 (case terminator 1365 (#\return (if (= line-end (+ contents-end 2)) 1366 :cp/m 1367 :macos)) 1368 (t :unix))))) 1369 (if (eq previous first-line) 1370 (progn 1371 (hi::insert-string mark chars) 1372 (hi::insert-character mark #\newline) 1373 (setq first-line nil)) 1374 (if (eq string-len contents-end) 1375 (hi::insert-string mark chars) 1376 (let* ((line (hi::make-line 1377 :previous previous 1378 :%buffer buffer 1379 :chars chars 1380 :number number))) 1381 (setf (hi::line-next previous) line) 1382 (setq previous line)))) 1383 (setq line-start line-end))))) 1384 first-line-terminator)) 1385 1266 1386 (defun nsstring-to-buffer (nsstring buffer) 1267 1387 (let* ((document (hi::buffer-document buffer)) … … 1273 1393 (hi::modifying-buffer buffer) 1274 1394 (hi::with-mark ((mark (hi::buffer-point buffer) :left-inserting)) 1275 (let* ((string-len (send nsstring 'length)) 1276 (line-start 0) 1277 (first-line-terminator ()) 1278 (first-line (hi::mark-line mark)) 1279 (previous first-line) 1280 (buffer (hi::line-%buffer first-line))) 1281 (slet ((remaining-range (ns-make-range 0 1))) 1282 (rlet ((line-end-index :unsigned) 1283 (contents-end-index :unsigned)) 1284 (do* ((number (+ (hi::line-number first-line) hi::line-increment) 1285 (+ number hi::line-increment))) 1286 ((= line-start string-len) 1287 (let* ((line (hi::mark-line mark))) 1288 (hi::insert-string mark (make-string 0)) 1289 (setf (hi::line-next previous) line 1290 (hi::line-previous line) previous)) 1291 nil) 1292 (setf (pref remaining-range :<NSR>ange.location) line-start) 1293 (send nsstring 1294 :get-line-start (%null-ptr) 1295 :end line-end-index 1296 :contents-end contents-end-index 1297 :for-range remaining-range) 1298 (let* ((contents-end (pref contents-end-index :unsigned)) 1299 (line-end (pref line-end-index :unsigned)) 1300 (chars (make-string (- contents-end line-start)))) 1301 (do* ((i line-start (1+ i)) 1302 (j 0 (1+ j))) 1303 ((= i contents-end)) 1304 (setf (schar chars j) (code-char (send nsstring :character-at-index i)))) 1305 (unless first-line-terminator 1306 (let* ((terminator (code-char 1307 (send nsstring :character-at-index 1308 contents-end)))) 1309 (setq first-line-terminator 1310 (case terminator 1311 (#\return (if (= line-end (+ contents-end 2)) 1312 :cp/m 1313 :macos)) 1314 (t :unix))))) 1315 (if (eq previous first-line) 1316 (progn 1317 (hi::insert-string mark chars) 1318 (hi::insert-character mark #\newline) 1319 (setq first-line nil)) 1320 (if (eq string-len contents-end) 1321 (hi::insert-string mark chars) 1322 (let* ((line (hi::make-line 1323 :previous previous 1324 :%buffer buffer 1325 :chars chars 1326 :number number))) 1327 (setf (hi::line-next previous) line) 1328 (setq previous line)))) 1329 (setq line-start line-end))))) 1330 (when first-line-terminator 1331 (setf (hi::buffer-external-format buffer) first-line-terminator)))) 1395 (setf (hi::buffer-external-format buffer) 1396 (%nsstring-to-mark nsstring mark))) 1397 ) 1332 1398 (setf (hi::buffer-modified buffer) nil) 1333 1399 (hi::buffer-start (hi::buffer-point buffer)) 1334 1400 buffer) 1335 (setf (hi::buffer-document buffer) document)))) 1336 1401 (setf (hi::buffer-document buffer) document))) 1402 1403 ;;; This assumes that the buffer has no document and no textstorage (yet). 1404 (defun hi::cocoa-read-file (lisp-pathname mark buffer) 1405 (let* ((lisp-namestring (native-translated-namestring lisp-pathname)) 1406 (cocoa-pathname (%make-nsstring lisp-namestring)) 1407 (hi::*buffer-gap-context* (hi::buffer-gap-context buffer)) 1408 (data (make-objc-instance 'ns:ns-data 1409 :with-contents-of-file cocoa-pathname)) 1410 (string (make-objc-instance 'ns:ns-string 1411 :with-data data 1412 :encoding #$NSASCIIStringEncoding)) 1413 (external-format (%nsstring-to-mark string mark))) 1414 (unless (hi::buffer-external-format buffer) 1415 (setf (hi::buffer-external-format buffer) external-format)) 1416 buffer)) 1417 1418 1337 1419 (setq hi::*beep-function* #'(lambda (stream) 1338 1420 (declare (ignore stream)) … … 1441 1523 1442 1524 1443 1525 (defun hi::buffer-note-font-change (buffer region) 1526 (when (hi::bufferp buffer) 1527 (let* ((document (hi::buffer-document buffer)) 1528 (textstorage (if document (slot-value document 'textstorage))) 1529 (pos (mark-absolute-position (hi::region-start region))) 1530 (n (- (mark-absolute-position (hi::region-end region)) pos))) 1531 (perform-edit-change-notification textstorage 1532 (@selector "noteAttrChange:") 1533 pos 1534 n)))) 1535 1444 1536 (defun hi::buffer-note-insertion (buffer mark n) 1445 1537 (when (hi::bufferp buffer) … … 1515 1607 (when (send scrollview 'has-vertical-scroller) 1516 1608 (send scrollview :set-vertical-line-scroll char-height) 1517 (send scrollview :set-vertical-page-scroll char-height))1609 (send scrollview :set-vertical-page-scroll 0.0f0 #|char-height|#)) 1518 1610 (when (send scrollview 'has-horizontal-scroller) 1519 1611 (send scrollview :set-horizontal-line-scroll char-width) 1520 (send scrollview :set-horizontal-page-scroll char-width))1612 (send scrollview :set-horizontal-page-scroll 0.0f0 #|char-width|#)) 1521 1613 (slet ((sv-size 1522 1614 (send (@class ns-scroll-view) … … 1561 1653 1562 1654 1655 (define-objc-method ((:id :init-with-text-storage ts) 1656 hemlock-editor-document) 1657 (let* ((doc (send-super 'init)) 1658 (string (send ts 'string)) 1659 (cache (hemlock-buffer-string-cache string)) 1660 (buffer (buffer-cache-buffer cache))) 1661 (unless (%null-ptr-p doc) 1662 (setf (slot-value doc 'textstorage) ts 1663 (hi::buffer-document buffer) doc)) 1664 doc)) 1665 1666 1667 1668 1669 1563 1670 (define-objc-method ((:id init) hemlock-editor-document) 1564 1671 (let* ((doc (send-super 'init))) 1565 ( unless (%null-ptr-p doc)1566 ( let* ((buffer (make-hemlock-buffer1567 (lisp-string-from-nsstring (send doc 'display-name)) 1568 :modes '("Lisp" "Editor")))) 1569 (setf (slot-value doc 'textstorage) 1570 (make-textstorage-for-hemlock-buffer buffer)1571 (hi::buffer-document buffer) doc)))1672 (when doc 1673 (send doc 1674 :init-with-text-storage (make-textstorage-for-hemlock-buffer 1675 (make-hemlock-buffer 1676 (lisp-string-from-nsstring 1677 (send doc 'display-name)) 1678 :modes '("Lisp" "Editor"))))) 1572 1679 doc)) 1573 1680 … … 1646 1753 (setf (hi::buffer-name buffer) (hi::pathname-to-buffer-name new-pathname)) 1647 1754 (setf (hi::buffer-pathname buffer) new-pathname))))) 1648 1755 1756 1757 (def-cocoa-default *initial-editor-x-pos* :float 200.0f0 "X position of upper-left corner of initial editor") 1758 1759 (def-cocoa-default *initial-editor-y-pos* :float 400.0f0 "Y position of upper-left corner of initial editor") 1760 1761 (defloadvar *next-editor-x-pos* nil) ; set after defaults initialized 1762 (defloadvar *next-editor-y-pos* nil) 1763 1649 1764 (define-objc-method ((:void make-window-controllers) hemlock-editor-document) 1650 1765 #+debug 1651 1766 (#_NSLog #@"Make window controllers") 1652 (let* ((controller (make-objc-instance 1653 'hemlock-editor-window-controller 1654 :with-window (%hemlock-frame-for-textstorage 1767 (let* ((window (%hemlock-frame-for-textstorage 1655 1768 (slot-value self 'textstorage) 1656 1769 *editor-columns* 1657 1770 *editor-rows* 1658 1771 nil 1659 (textview-background-color self))))) 1772 (textview-background-color self))) 1773 (controller (make-objc-instance 1774 'hemlock-editor-window-controller 1775 :with-window window))) 1660 1776 (send self :add-window-controller controller) 1661 (send controller 'release))) 1777 (send controller 'release) 1778 (slet ((current-point (ns-make-point (or *next-editor-x-pos* 1779 *initial-editor-x-pos*) 1780 (or *next-editor-y-pos* 1781 *initial-editor-y-pos*)))) 1782 (slet ((new-point (send window 1783 :cascade-top-left-from-point current-point))) 1784 (setf *next-editor-x-pos* (pref new-point :<NSP>oint.x) 1785 *next-editor-y-pos* (pref new-point :<NSP>oint.y)))))) 1662 1786 1663 1787 … … 1666 1790 (setf (slot-value self 'textstorage) (%null-ptr)) 1667 1791 (unless (%null-ptr-p textstorage) 1792 (for-each-textview-using-storage 1793 textstorage 1794 #'(lambda (tv) (send tv :set-string #@""))) 1668 1795 (close-hemlock-textstorage textstorage))) 1669 1796 (send-super 'close)) … … 1685 1812 :with-object (%null-ptr) 1686 1813 :wait-until-done t))))) 1814 1815 (defmethod hemlock::center-text-pane ((pane text-pane)) 1816 (send (text-pane-text-view pane) 1817 :center-selection-in-visible-area (%null-ptr))) 1818 1819 1820 (defmethod hi::save-hemlock-document ((self hemlock-editor-document)) 1821 (send self :save-document (%null-ptr))) 1687 1822 1688 1823 ;;; This needs to run on the main thread. … … 1713 1848 :update-selection location 1714 1849 :length len 1715 :affinity #$NSSelectionAffinityUpstream))))) 1850 :affinity (if (eql location 0) 1851 #$NSSelectionAffinityUpstream 1852 #$NSSelectionAffinityDownstream)))))) 1716 1853 1717 1854 -
trunk/ccl/examples/cocoa-listener.lisp
r765 r793 9 9 (def-cocoa-default *listener-rows* :int 16 "Initial height of listener windows, in characters") 10 10 (def-cocoa-default *listener-columns* :int 80 "Initial height of listener windows, in characters") 11 12 (def-cocoa-default hi::*listener-output-style* :int 0 "Text style index for listener output") 13 14 (def-cocoa-default hi::*listener-input-style* :int 1 "Text style index for listener output") 11 15 12 16 (def-cocoa-default *listener-background-red-component* :float 0.90f0 "Red component of editor background color. Should be a float between 0.0 and 1.0, inclusive.") … … 112 116 :object-for-key *NSFileHandleNotificationDataItem*)) 113 117 (document (send self 'document)) 114 (textstorage (slot-value document 'textstorage))115 118 (data-length (send data 'length)) 116 119 (buffer (hemlock-document-buffer document)) … … 121 124 buffer 122 125 #'(lambda () 123 (let* ((input-mark (hi::variable-value 'hemlock::buffer-input-mark :buffer buffer))) 124 (hi:with-mark ((mark input-mark :left-inserting)) 125 (hi::insert-string mark string) 126 (hi::move-mark input-mark mark))) 127 (send textstorage 128 :perform-selector-on-main-thread 129 (@selector "ensureSelectionVisible") 130 :with-object (%null-ptr) 131 :wait-until-done t))) 126 (hemlock::append-buffer-output buffer string))) 132 127 (send fh 'read-in-background-and-notify)))) 133 128 … … 207 202 doc)) 208 203 204 (def-cocoa-default *initial-listener-x-pos* :float 400.0f0 "X position of upper-left corner of initial listener") 205 206 (def-cocoa-default *initial-listener-y-pos* :float 400.0f0 "Y position of upper-left corner of initial listener") 207 208 (defloadvar *next-listener-x-pos* nil) ; set after defaults initialized 209 (defloadvar *next-listener-y-pos* nil) ; likewise 210 209 211 (define-objc-method ((:void make-window-controllers) hemlock-listener-document) 210 212 (let* ((textstorage (slot-value self 'textstorage)) 211 (controller (make-objc-instance 212 'hemlock-listener-window-controller 213 :with-window (%hemlock-frame-for-textstorage 213 (window (%hemlock-frame-for-textstorage 214 214 textstorage 215 215 *listener-columns* 216 216 *listener-rows* 217 217 t 218 (textview-background-color self)))) 218 (textview-background-color self))) 219 (controller (make-objc-instance 220 'hemlock-listener-window-controller 221 :with-window window)) 219 222 (listener-name (hi::buffer-name (hemlock-document-buffer self)))) 220 223 (send self :add-window-controller controller) 221 224 (send controller 'release) 225 (slet ((current-point (ns-make-point (or *next-listener-x-pos* 226 *initial-listener-x-pos*) 227 (or *next-listener-y-pos* 228 *initial-listener-y-pos*)))) 229 (slet ((new-point (send window 230 :cascade-top-left-from-point current-point))) 231 (setf *next-listener-x-pos* (pref new-point :<NSP>oint.x) 232 *next-listener-y-pos* (pref new-point :<NSP>oint.y)))) 222 233 (setf (hi::buffer-process (hemlock-document-buffer self)) 223 234 (let* ((tty (slot-value controller 'clientfd))
Note:
See TracChangeset
for help on using the changeset viewer.
