Changeset 556
- Timestamp:
- Feb 21, 2004, 5:21:01 PM (21 years ago)
- File:
-
- 1 edited
-
trunk/ccl/examples/hemlock-textstorage.lisp (modified) (15 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/ccl/examples/hemlock-textstorage.lisp
r430 r556 6 6 (use-interface-dir :cocoa)) 7 7 8 (defvar *buffer-id-map* (make-id-map))9 8 10 9 (defstruct hemlock-display … … 32 31 33 32 (defclass hemlock-buffer-string (ns:ns-string) 34 (( id :foreign-type :unsigned))33 ((display :initform nil :initarg :display :accessor hemlock-buffer-string-display)) 35 34 (:metaclass ns:+ns-object)) 35 36 36 37 37 (defun update-line-cache-for-index (d index) … … 85 85 hemlock-buffer-string) 86 86 ;(#_NSLog #@"Character at index %d" :unsigned index ) 87 (char-code (hemlock-char-at-index 88 (id-map-object *buffer-id-map* (slot-value self 'id)) index))) 87 (char-code (hemlock-char-at-index (hemlock-buffer-string-display self) index))) 89 88 90 89 91 90 (define-objc-method ((:unsigned length) 92 91 hemlock-buffer-string) 93 (let* ((display-object ( id-map-object *buffer-id-map* (slot-value self 'id))))92 (let* ((display-object (hemlock-buffer-string-display self))) 94 93 (or (hemlock-display-buflen display-object) 95 94 (setf (hemlock-display-buflen display-object) … … 97 96 98 97 99 (define-objc-method ((:unsigned lisp-id)100 hemlock-buffer-string)101 (slot-value self 'id))102 98 103 99 (define-objc-method ((:id description) 104 100 hemlock-buffer-string) 105 (send (@class ns-string) :string-with-format #@"%s : stringid %d/len %d" 106 (:address (#_object_getClassName self) 107 :unsigned (slot-value self 'id) 108 :unsigned (send self 'length)))) 109 110 (define-objc-method ((:id :init-with-buffer-id (:unsigned n)) 111 hemlock-buffer-string) 112 (send-super 'init) 113 (setf (slot-value self 'id) n) 114 self) 115 116 101 (let* ((d (hemlock-buffer-string-display self)) 102 (b (hemlock-display-buffer d))) 103 (with-cstrs ((s (format nil "~a" b))) 104 (send (@class ns-string) :string-with-format #@"<%s for %s>" 105 (:address (#_object_getClassName self) :address s))))) 117 106 118 107 … … 122 111 (:metaclass ns:+ns-object)) 123 112 124 113 (define-objc-method ((:id :init-with-string s) lisp-text-storage) 114 (let* ((newself (send-super 'init))) 115 (setf (slot-value newself 'string) s 116 (slot-value newself 'defaultattrs) (create-text-attributes)) 117 newself)) 118 125 119 (define-objc-method ((:id string) lisp-text-storage) 126 120 (slot-value self 'string)) … … 131 125 '(#_NSLog #@"Attributes at index %d, rangeptr = %x" 132 126 :unsigned index :address rangeptr) 133 (let* ((hemlock-display ( id-map-object *buffer-id-map* (send (slot-value self 'string) 'lisp-id)))127 (let* ((hemlock-display (hemlock-buffer-string-display (slot-value self 'string))) 134 128 (len (hemlock-display-buflen hemlock-display))) 135 129 (if (>= index len) … … 164 158 :unsigned (pref r :<NSR>ange.length))) 165 159 166 (define-objc-method ((:id :init-with-buffer-id (:unsigned buffer-id-number))167 lisp-text-storage)168 (send-super 'init)169 (with-slots (string defaultattrs) self170 (setq string (make-objc-instance171 'hemlock-buffer-string172 :with-buffer-id buffer-id-number))173 (setq defaultattrs (create-text-attributes)))174 self)175 176 177 160 178 161 (define-objc-method ((:id description) 179 162 lisp-text-storage) 180 163 (send (@class ns-string) :string-with-format #@"%s : string %@" 181 (:address (#_object_getClassName self) 182 :id (slot-value self 'string)))) 164 (:address (#_object_getClassName self) :id (slot-value self 'string)))) 183 165 184 166 185 167 (defclass lisp-text-view (ns:ns-text-view) 186 () 168 ((timer :foreign-type :id :accessor blink-timer) 169 (blink-pos :foreign-type :int :accessor blink-pos) 170 (blink-phase :foreign-type :<BOOL> :accessor blink-phase) 171 (blink-char :foreign-type :int :accessor blink-char)) 187 172 (:metaclass ns:+ns-object)) 188 173 174 (defmethod text-view-buffer ((self lisp-text-view)) 175 (hemlock-display-buffer (hemlock-buffer-string-display (send (send self 'text-storage) 'string)))) 176 177 ;;; HEMLOCK-EXT::DEFINE-CLX-MODIFIER is kind of misnamed; we can use 178 ;;; it to map NSEvent modifier keys to key-event modifiers. 179 (hemlock-ext::define-clx-modifier #$NSShiftKeyMask "Shift") 180 (hemlock-ext::define-clx-modifier #$NSControlKeyMask "Control") 181 (hemlock-ext::define-clx-modifier #$NSAlternateKeyMask "Meta") 182 (hemlock-ext::define-clx-modifier #$NSAlphaShiftKeyMask "Lock") 183 184 (defun nsevent-to-key-event (nsevent) 185 (let* ((unmodchars (send nsevent 'characters-ignoring-modifiers)) 186 (n (if (%null-ptr-p unmodchars) 187 0 188 (send unmodchars 'length))) 189 (c (if (eql n 1) 190 (send unmodchars :character-at-index 0)))) 191 (when c 192 (let* ((bits 0) 193 (modifiers (send nsevent 'modifier-flags))) 194 (dolist (map hemlock-ext::*modifier-translations*) 195 (when (logtest modifiers (car map)) 196 (setq bits (logior bits (hemlock-ext::key-event-modifier-mask 197 (cdr map)))))) 198 (hemlock-ext::make-key-event c bits))))) 199 200 189 201 (define-objc-method ((:void :key-down event) 190 202 lisp-text-view) 191 (#_NSLog #@"Key down event : %@" :address event) 192 (send-super :key-down event)) 203 (#_NSLog #@"Key down event = %@" :address event) 204 (format t "~& keycode = ~s~&" (send event 'key-code)) 205 (let* ((buffer (text-view-buffer self))) 206 (when buffer 207 (let* ((info (hemlock-frame-command-info (send self 'window)))) 208 (when info 209 (let* ((key-event (nsevent-to-key-event event))) 210 (when event 211 (unless (eq buffer hi::*current-buffer*) 212 (setf (hi::current-buffer) buffer)) 213 (hi::interpret-key-event key-event info)))))))) 193 214 194 215 (define-objc-method ((:void :set-selected-range (:<NSR>ange r) … … 196 217 :still-selecting (:<BOOL> still-selecting)) 197 218 lisp-text-view) 198 (let* ((d (id-map-object *buffer-id-map* 199 (send (send self 'string) 'lisp-id))) 219 (let* ((d (hemlock-buffer-string-display (send self 'string))) 200 220 (point (hemlock::buffer-point (hemlock-display-buffer d))) 201 221 (location (pref r :<NSR>ange.location)) … … 207 227 :still-selecting still-selecting))) 208 228 209 210 211 (define-objc-class-method ((:id :scrollview-with-rect (:<NSR>ect contentrect) 212 :lisp-buffer-id (:unsigned stringid) 213 :horizontal-scroll-p (:<BOOL> hscroll-p)) 214 lisp-text-view) 215 (let* ((textstorage (make-objc-instance 216 'lisp-text-storage 217 :with-buffer-id stringid)) 218 (scrollview 219 (send (make-objc-instance 220 'ns-scroll-view 221 :with-frame contentrect) 222 'autorelease))) 229 230 (defun make-textstorage-for-hemlock-buffer (buffer) 231 (setf (hi::buffer-text-storage buffer) 232 (make-objc-instance 'lisp-text-storage 233 :with-string 234 (make-instance 235 'hemlock-buffer-string 236 :display 237 (reset-display-cache 238 (make-hemlock-display) 239 buffer))))) 240 241 (defun make-scrolling-text-view-for-buffer (buffer x y width height hscroll-p) 242 (slet ((contentrect (ns-make-rect x y width height))) 243 (let* ((textstorage (make-textstorage-for-hemlock-buffer buffer)) 244 (scrollview (send (make-objc-instance 245 'ns-scroll-view 246 :with-frame contentrect) 'autorelease))) 223 247 (send scrollview :set-border-type #$NSBezelBorder) 224 248 (send scrollview :set-has-vertical-scroller t) 225 249 (send scrollview :set-has-horizontal-scroller hscroll-p) 226 250 (send scrollview :set-rulers-visible nil) 227 (send scrollview :set-autoresizing-mask (logior #$NSViewWidthSizable 228 #$NSViewHeightSizable)) 251 (send scrollview :set-autoresizing-mask (logior 252 #$NSViewWidthSizable 253 #$NSViewHeightSizable)) 229 254 (send (send scrollview 'content-view) :set-autoresizes-subviews t) 230 255 (let* ((layout (make-objc-instance 'ns-layout-manager))) … … 233 258 (slet* ((contentsize (send scrollview 'content-size)) 234 259 (containersize (ns-make-size 235 236 260 1.0f7 261 1.0f7)) 237 262 (tv-frame (ns-make-rect 238 239 240 241 242 263 0.0f0 264 0.0f0 265 (pref contentsize :<NSS>ize.width) 266 (pref contentsize :<NSS>ize.height)))) 267 (let* ((container (send (make-objc-instance 243 268 'ns-text-container 244 269 :with-container-size containersize) 245 270 'autorelease))) 246 271 (send layout :add-text-container container) 247 (let* ((tv (send 248 (send (send self 'alloc) 249 :init-with-frame tv-frame 250 :text-container container) 251 'autorelease))) 272 (let* ((tv (send (make-objc-instance 'lisp-text-view 273 :with-frame tv-frame 274 :text-container container) 275 'autorelease))) 252 276 (send tv :set-min-size (ns-make-size 253 277 0.0f0 … … 261 285 (send container :set-height-tracks-text-view nil) 262 286 (send scrollview :set-document-view tv) 263 tv)))))) 264 265 266 267 (define-objc-class-method ((:id :scrollview-for-window window 268 :buffer-id (:unsigned buffer-id) 269 :horizontal-scroll-p (:<BOOL> hscroll-p)) 270 lisp-text-view) 271 (let* ((contentview (send window 'content-view))) 272 (slet ((contentrect (send contentview 'frame))) 273 (let* ((tv (send 274 (@class lisp-text-view) 275 :scrollview-with-rect contentrect 276 :lisp-buffer-id buffer-id 277 :horizontal-scroll-p hscroll-p)) 278 (scrollview (send (send tv 'superview) 'superview))) 279 (send window :set-content-view scrollview) 280 tv)))) 281 287 (values tv scrollview)))))))) 288 289 290 (defun make-scrolling-textview-for-view (superview buffer hscroll-p) 291 (slet ((contentrect (send (send superview 'content-view) 'frame))) 292 (multiple-value-bind (tv scrollview) 293 (make-scrolling-text-view-for-buffer 294 buffer 295 (pref contentrect :<NSR>ect.origin.x) 296 (pref contentrect :<NSR>ect.origin.y) 297 (pref contentrect :<NSR>ect.size.width) 298 (pref contentrect :<NSR>ect.size.height) 299 hscroll-p) 300 (send superview :set-content-view scrollview) 301 tv))) 302 303 (defun make-scrolling-textview-for-window (&key window buffer hscroll-p) 304 (make-scrolling-textview-for-view (send window 'content-view) buffer hscroll-p)) 305 306 (defmethod hemlock-frame-command-info ((w ns:ns-window)) 307 nil) 308 309 (defclass hemlock-frame (ns:ns-window) 310 ((command-info :initform (hi::make-command-interpreter-info) 311 :accessor hemlock-frame-command-info)) 312 (:metaclass ns:+ns-object)) 313 314 (defmethod shared-initialize :after ((w hemlock-frame) 315 slot-names 316 &key &allow-other-keys) 317 (declare (ignore slot-names)) 318 (let ((info (hemlock-frame-command-info w))) 319 (when info 320 (setf (hi::command-interpreter-info-frame info) w)))) 282 321 283 322 (defun get-cocoa-window-flag (w flagname) … … 289 328 (:auto-display 290 329 (send w 'is-autodisplay)))) 291 330 292 331 (defun (setf get-cocoa-window-flag) (value w flagname) 293 332 (case flagname … … 301 340 (send w :make-key-and-order-front nil)) 302 341 303 (defun new-cocoa-document-window (title &key 304 (class-name "NSWindow") 305 (x 0.0) 306 (y 0.0) 307 (height 200.0) 308 (width 500.0) 309 (closable t) 310 (iconifyable t) 311 (metal t) 312 (expandable t) 313 (backing :buffered) 314 (defer nil) 315 (accepts-mouse-moved-events nil) 316 (auto-display t) 317 (activate t)) 342 (defun new-hemlock-document-window (title &key 343 (x 0.0) 344 (y 0.0) 345 (height 200.0) 346 (width 500.0) 347 (closable t) 348 (iconifyable t) 349 (metal t) 350 (expandable t) 351 (backing :buffered) 352 (defer nil) 353 (accepts-mouse-moved-events nil) 354 (auto-display t) 355 (activate t)) 318 356 (rlet ((frame :<NSR>ect :origin.x (float x) :origin.y (float y) :size.width (float width) :size.height (float height))) 319 357 (let* ((stylemask … … 328 366 ((nil :nonretained) #$NSBackingStoreNonretained) 329 367 (:buffered #$NSBackingStoreBuffered))) 330 (w (make- objc-instance331 class-name368 (w (make-instance 369 'hemlock-frame 332 370 :with-content-rect frame 333 371 :style-mask stylemask … … 340 378 auto-display) 341 379 (when activate (activate-window w)) 342 w))) 343 344 (defun textview-for-buffer (id &key (horizontal-scroll-p t)) 380 (values w (add-box-to-window w :reserve-below 20.0))))) 381 382 (defun add-box-to-window (w &key (reserve-above 0.0f0) (reserve-below 0.0f0)) 383 (let* ((window-content-view (send w 'content-view))) 384 (slet ((window-frame (send window-content-view 'frame))) 385 (slet ((box-rect (ns-make-rect 0.0f0 386 reserve-below 387 (pref window-frame :<NSR>ect.size.width) 388 (- (pref window-frame :<NSR>ect.size.height) (+ reserve-above reserve-below))))) 389 (let* ((box (make-objc-instance 'ns-box :with-frame box-rect))) 390 (send box :set-autoresizing-mask (logior 391 #$NSViewWidthSizable 392 #$NSViewHeightSizable)) 393 (send box :set-box-type #$NSBoxSecondary) 394 (send box :set-border-type #$NSLineBorder) 395 (send box :set-title-position #$NSBelowBottom) 396 (send window-content-view :add-subview box) 397 box))))) 398 399 400 401 (defun textview-for-hemlock-buffer (b &key (horizontal-scroll-p t)) 345 402 (process-interrupt 346 403 *cocoa-event-process* 347 404 #'(lambda () 348 (let* ((d (id-map-object *buffer-id-map* id)) 349 (name (hi::buffer-name (hemlock-display-buffer d))) 350 (w (new-cocoa-document-window name :activate nil)) 351 (tv 352 (send (@class lisp-text-view) 353 :scrollview-for-window w 354 :buffer-id id 355 :horizontal-scroll-p horizontal-scroll-p))) 356 (multiple-value-bind (height width) 357 (size-of-char-in-font (default-font)) 358 (size-textview-containers tv height width 24 80)) 359 (activate-window w) 360 tv)))) 361 362 (defun put-textview-in-box (box) 363 (slet ((r (send (send box 'content-view) 'bounds))) 364 (let* ((sv (make-objc-instance 'ns-scroll-view :with-frame r)) 365 (sv-content-view (send sv 'content-view))) 366 (declare (ignorable sv-content-view)) 367 (send box :set-content-view sv) 368 (slet ((sv-content-size (send sv 'content-size))) 369 (slet ((tv-frame (ns-make-rect 0.0f0 0.0f0 370 (pref sv-content-size :<NSS>ize.width) 371 (pref sv-content-size :<NSS>ize.height)))) 372 (let* ((tv (make-objc-instance 'ns-text-view 373 :with-frame tv-frame))) 374 (send sv :set-document-view tv) 375 (send box :set-content-view sv) 376 (values tv sv))))))) 405 (let* ((name (hi::buffer-name b))) 406 (multiple-value-bind (window box) 407 (new-hemlock-document-window name :activate nil) 408 (let* ((tv (make-scrolling-textview-for-view box 409 b 410 horizontal-scroll-p))) 411 (multiple-value-bind (height width) 412 (size-of-char-in-font (default-font)) 413 (size-textview-containers tv height width 24 80)) 414 (activate-window window) 415 tv)))))) 416 377 417 378 418 (defun read-file-to-hemlock-buffer (path) 379 (let* ((buffer (hemlock::find-file-buffer path))) 380 (reset-display-cache (make-hemlock-display) buffer))) 381 419 (hemlock::find-file-buffer path)) 420 421 (defun hemlock-buffer-from-nsstring (nsstring name) 422 (let* ((buffer (hi::make-buffer name))) 423 (hi::delete-region (hi::buffer-region buffer)) 424 (hi::modifying-buffer buffer) 425 (hi::with-mark ((mark (hi::buffer-point buffer) :left-inserting)) 426 (let* ((string-len (send nsstring 'length)) 427 (line-start 0) 428 (first-line (hi::mark-line mark)) 429 (previous first-line) 430 (buffer (hi::line-%buffer first-line))) 431 (slet ((remaining-range (ns-make-range 0 1))) 432 (rlet ((line-end-index :unsigned) 433 (contents-end-index :unsigned)) 434 (do* ((number (+ (hi::line-number first-line) hi::line-increment) 435 (+ number hi::line-increment))) 436 ((= line-start string-len)) 437 (setf (pref remaining-range :<NSR>ange.location) line-start) 438 (send nsstring 439 :get-line-start (%null-ptr) 440 :end line-end-index 441 :contents-end contents-end-index 442 :for-range remaining-range) 443 (let* ((contents-end (pref contents-end-index :unsigned)) 444 (chars (make-string (- contents-end line-start)))) 445 (do* ((i line-start (1+ i)) 446 (j 0 (1+ j))) 447 ((= i contents-end)) 448 (setf (schar chars j) (code-char (send nsstring :character-at-index i)))) 449 (if (eq previous first-line) 450 (progn 451 (hi::insert-string mark chars) 452 (hi::insert-character mark #\newline) 453 (setq first-line nil)) 454 (if (eq (pref line-end-index :unsigned) string-len) 455 (hi::insert-string mark chars) 456 (let* ((line (hi::make-line 457 :previous previous 458 :%buffer buffer 459 :chars chars 460 :number number))) 461 (setf (hi::line-next previous) line) 462 (setq previous line)))) 463 (setq line-start (pref line-end-index :unsigned)))))))) 464 buffer)) 465 466 (setq hi::*beep-function* #'(lambda (stream) 467 (declare (ignore stream)) 468 (#_NSBeep))) 382 469 383 470 (defun edit (path) 384 (textview-for-buffer (assign-id-map-id *buffer-id-map* 385 (read-file-to-hemlock-buffer path)))) 471 (textview-for-hemlock-buffer (read-file-to-hemlock-buffer path))) 472 473 (defun for-each-textview-using-storage (textstorage f) 474 (let* ((layouts (send textstorage 'layout-managers))) 475 (unless (%null-ptr-p layouts) 476 (dotimes (i (send layouts 'count)) 477 (let* ((layout (send layouts :object-at-index i)) 478 (containers (send layout 'text-containers))) 479 (unless (%null-ptr-p containers) 480 (dotimes (j (send containers 'count)) 481 (let* ((container (send containers :object-at-index j)) 482 (tv (send container 'text-view))) 483 (funcall f tv))))))))) 484 485 486 (defun hi::textstorage-set-point-position (textstorage) 487 (format t "~& setting point ...") 488 (let* ((string (send textstorage 'string)) 489 (buffer (hemlock-display-buffer (hemlock-buffer-string-display string))) 490 (point (hi::buffer-point buffer)) 491 (pos (mark-absolute-position point))) 492 (for-each-textview-using-storage 493 textstorage 494 #'(lambda (tv) 495 (send tv :set-selected-range (ns-make-range pos 0)))))) 496 497 498
Note:
See TracChangeset
for help on using the changeset viewer.
