home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / source / oodleutl.cpt / oodles-of-utils / mixin-madness / dialog-item-mixins / te-dim.lisp < prev   
Encoding:
Text File  |  1992-07-15  |  12.7 KB  |  347 lines
  1. (in-package :oou)
  2. (oou-provide :te-dim)
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;; te-dim.Lisp
  5. ;;
  6. ;; Copyright ⌐ 1992 Northwestern University Institute for the Learning Sciences
  7. ;; All Rights Reserved
  8. ;;
  9. ;; author: Michael S. Engber
  10. ;;
  11. ;; mixin for adding text edit functionality to views
  12. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13.  
  14. (oou-dependencies :simple-view-ce
  15.                   :resources-u
  16.                   :te-blob)
  17.  
  18. (export '(te-dim te-margins
  19.           te-set-font te-selection te-set-selection
  20.           te-set-text-rsrc te-save-text-rsrc te-string
  21.           ))
  22.  
  23. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  24.  
  25. (defclass te-dim (key-handler-mixin)
  26.   ((te-blob         :accessor te-blob)
  27.    (te-just         :initarg :te-just
  28.                     :accessor te-just)
  29.    (te-word-wrap-p  :initarg :te-word-wrap-p
  30.                     :accessor te-word-wrap-p)
  31.    (te-init-string  :initarg :te-init-string
  32.                     :initarg :dialog-item-text
  33.                     :accessor te-init-string)
  34.    (te-init-rsrc    :initarg :te-init-rsrc
  35.                     :accessor te-init-rsrc)
  36.    (te-read-only-p  :initarg :te-read-only-p
  37.                     :accessor te-read-only-p)
  38.    (te-v-scroll-bar :initarg :te-v-scroll-bar
  39.                     :accessor te-v-scroll-bar)
  40.    (te-h-scroll-bar :initarg :te-h-scroll-bar
  41.                     :accessor te-h-scroll-bar)
  42.    (te-v-line-size  :initarg :te-v-line-size
  43.                     :accessor te-v-line-size)
  44.    (te-h-line-size  :initarg :te-h-line-size
  45.                     :accessor te-h-line-size))
  46.   (:default-initargs
  47.     :te-init-string "hi,ho"
  48.     :te-just        :default
  49.     :te-word-wrap-p t
  50.     :te-read-only-p nil
  51.     :te-v-line-size 5
  52.     :te-h-line-size 5
  53.     ))
  54.  
  55.  
  56. (defmethod te-fix-scroll-limit ((di te-dim) direction max)
  57.   (ecase direction
  58.     (:vertical
  59.      (when (slot-boundp di 'te-v-scroll-bar)
  60.        (set-scroll-bar-max (te-v-scroll-bar di) max)
  61.        ))
  62.     (:horizontal
  63.      (when (slot-boundp di 'te-h-scroll-bar)
  64.        (set-scroll-bar-max (te-h-scroll-bar di) max)))))
  65.  
  66. (defmethod te-fix-scroll-value ((di te-dim) direction value)
  67.   (ecase direction
  68.     (:vertical
  69.      (when (slot-boundp di 'te-v-scroll-bar)
  70.        (set-scroll-bar-setting (te-v-scroll-bar di) value)))
  71.     (:horizontal
  72.      (when (slot-boundp di 'te-h-scroll-bar)
  73.        (set-scroll-bar-setting (te-h-scroll-bar di) value)))))
  74.  
  75.  
  76. (defmethod install-view-in-window :after ((di te-dim) window)
  77.   (multiple-value-bind (topLeft botRight) (te-corners di)
  78.     (let ((te-size (subtract-points botRight topLeft)))
  79.     
  80.     ;set up the vertical scroll bar
  81.     (when (slot-boundp di 'te-v-scroll-bar)
  82.       (when (symbolp (te-v-scroll-bar di))
  83.         (unless (setf (te-v-scroll-bar di) (find-named-sibling di (te-v-scroll-bar di)))
  84.           (slot-makunbound di 'te-v-scroll-bar)
  85.           (error "unable to find scroll bar item named ~a." (te-v-scroll-bar di))))
  86.       (set-scroll-bar-scrollee (te-v-scroll-bar di) di)
  87.       (set-scroll-bar-min (te-v-scroll-bar di) 0)
  88.       (setf (scroll-bar-page-size (te-v-scroll-bar di)) (- (point-v te-size) (te-v-line-size di)))
  89.       (setf (slot-value (te-v-scroll-bar di) 'ccl::scroll-size) (te-v-line-size di)))
  90.     
  91.     ;set up the horizontal scroll bar
  92.     (when (slot-boundp di 'te-h-scroll-bar)
  93.       (when (symbolp (te-h-scroll-bar di))
  94.         (unless (setf (te-h-scroll-bar di) (find-named-sibling di (te-h-scroll-bar di)))
  95.           (slot-makunbound di 'te-h-scroll-bar)
  96.           (error "unable to find scroll bar item named ~a." (te-h-scroll-bar di))))
  97.       (set-scroll-bar-scrollee (te-h-scroll-bar di) di)
  98.       (set-scroll-bar-min (te-h-scroll-bar di) 0)
  99.       (setf (scroll-bar-page-size (te-h-scroll-bar di)) (- (point-h te-size) (te-h-line-size di)))
  100.       (setf (slot-value (te-h-scroll-bar di) 'ccl::scroll-size) (te-h-line-size di)))
  101.     
  102.     (flet ((fix-scroll-limit (direction max)
  103.              (te-fix-scroll-limit di direction max))
  104.            (fix-scroll-value (direction value)
  105.              (te-fix-scroll-value di direction value)))
  106.       
  107.       (setf (te-blob di) (make-instance 'te-blob
  108.                            :te-port           (wptr window)
  109.                            :te-topLeft         topLeft
  110.                            :te-botRight        botRight
  111.                            :te-just            (te-just di)
  112.                            :te-v-scroll-p      (slot-boundp di 'te-v-scroll-bar)
  113.                            :te-h-scroll-p      (slot-boundp di 'te-h-scroll-bar)
  114.                            :te-word-wrap-p     (te-word-wrap-p di)
  115.                            :te-scroll-value-fn #'fix-scroll-value
  116.                            :te-scroll-limit-fn #'fix-scroll-limit)))))
  117.   (te-init-text di))
  118.  
  119. (defmethod remove-view-from-window :after ((di te-dim))
  120.   (te-free (te-blob di))
  121.   (slot-makunbound di 'te-blob))
  122.  
  123. (defmethod te-init-text ((di te-dim))
  124.   (if (slot-boundp di 'te-init-rsrc)
  125.     (te-set-text-rsrc di (te-init-rsrc di))
  126.     (set-dialog-item-text di (te-init-string di))))
  127.  
  128. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  129.  
  130. ;;returns the init-rsrc's id (useful if it was specified by name)
  131. (defmethod te-init-rsrc-id ((di te-dim))
  132.   (when (slot-boundp di 'te-init-rsrc)
  133.     (etypecase (te-init-rsrc di)
  134.       (fixnum (te-init-rsrc di))
  135.       (string (get-resource-id "TEXT" (te-init-rsrc di))))))
  136.  
  137. ;;returns the init-rsrc's name (useful if it was specified by id)
  138. (defmethod te-init-rsrc-name ((di te-dim))
  139.   (when (slot-boundp di 'te-init-rsrc)
  140.     (etypecase (te-init-rsrc di)
  141.       (fixnum (get-resource-name "TEXT" (te-init-rsrc di)))
  142.       (string (te-init-rsrc di)))))
  143.  
  144. (defmethod te-set-text-rsrc ((di te-dim) rsrc-id-or-name)
  145.   (with-focused-view (focusing-view di)
  146.     (with-font-spec (view-font di)
  147.       (with-macptrs ((text-handle  (get-resource "TEXT" rsrc-id-or-name :errorp t))
  148.                      (style-handle (get-resource "styl" rsrc-id-or-name :errorp nil)))
  149.         (set-te-handles (te-blob di) text-handle (unless (%null-ptr-p style-handle) style-handle))
  150.         (release-resource text-handle)
  151.         (unless (%null-ptr-p style-handle) (release-resource style-handle)))
  152.       rsrc-id-or-name)))
  153.  
  154. (defmethod te-set-text-rsrc :after ((di te-dim) rsrc-id-or-name)
  155.   (declare (ignore rsrc-id-or-name))
  156.   (invalidate-view di t))
  157.  
  158. (defmethod te-save-text-rsrc ((di te-dim) &key rsrc-id rsrc-name)
  159.   
  160.   ;determine id & name of 'TEXT' & 'styl' resource
  161.   (if (slot-boundp di 'te-init-rsrc)
  162.     (setf rsrc-id   (or rsrc-id   (te-init-rsrc-id di))
  163.           rsrc-name (or rsrc-name (te-init-rsrc-name di)))
  164.     (setf rsrc-id   (or rsrc-id   (#_UniqueId "TEXT"))
  165.           rsrc-name (or rsrc-name "un-named")))
  166.   
  167.   ;remove any existing 'TEXT' & 'styl' resources with same id
  168.   (with-macptrs ((old-text-handle  (get-resource "TEXT" rsrc-id :errorp nil))
  169.                  (old-style-handle (get-resource "styl" rsrc-id :errorp nil)))
  170.     (unless (%null-ptr-p old-text-handle)  (#_RmveResource old-text-handle))
  171.     (unless (%null-ptr-p old-style-handle) (#_RmveResource old-style-handle)))
  172.   
  173.   ;add the 'TEXT' & 'styl' resources to current res file
  174.   (multiple-value-bind (text-handle style-handle) (te-handles (te-blob di))
  175.     (with-pstrs ((name-ptr rsrc-name))
  176.       (#_AddResource text-handle  "TEXT" rsrc-id name-ptr)
  177.       (#_WriteResource text-handle)
  178.       (#_AddResource style-handle "styl" rsrc-id name-ptr)
  179.       (#_WriteResource style-handle))
  180.     (#_DisposeHandle text-handle)
  181.     (#_DisposeHandle style-handle))
  182.   
  183.   rsrc-id)
  184.  
  185.  
  186. (defmethod point-in-te-region-p ((di te-dim) pt)
  187.   (multiple-value-bind (topLeft botRight) (te-corners di)
  188.     (rlet ((r :Rect
  189.               :topLeft  topLeft
  190.               :botRight botRight))
  191.       (#_PtInRect pt r))))
  192.  
  193. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  194.  
  195. (defmethod view-click-event-handler ((di te-dim) where)
  196.   (if (point-in-te-region-p di where)
  197.     (te-click-handler (te-blob di) where)
  198.     (call-next-method)))
  199.  
  200. (defmethod view-key-event-handler ((di te-dim) char)
  201.   (unless (te-read-only-p di)
  202.     (with-focused-view (focusing-view di)
  203.       (te-key (te-blob di) char))))
  204.  
  205. (defmethod key-handler-idle ((di te-dim) &optional dialog)
  206.   (declare (ignore dialog))
  207.   (with-focused-view (focusing-view di)
  208.   (te-idle (te-blob di))))
  209.  
  210. (defmethod view-activate-event-handler ((di te-dim))
  211.   (te-activate (te-blob di)))
  212.  
  213. (defmethod view-deactivate-event-handler ((di te-dim))
  214.   (te-deactivate (te-blob di)))
  215.  
  216. (defmethod set-view-position :after ((di te-dim) h &optional v)
  217.   (declare (ignore h v))
  218.   (multiple-value-bind (topLeft botRight) (te-corners di)
  219.     (set-te-corners (te-blob di) topLeft botRight)))
  220.  
  221. (defmethod set-view-size :after ((di te-dim) h &optional v)
  222.   (multiple-value-bind (topLeft botRight) (te-corners di)
  223.     (set-te-corners (te-blob di) topLeft botRight))
  224.   (let ((te-size (make-point h v)))
  225.     (when (slot-boundp di 'te-v-scroll-bar)
  226.       (setf (scroll-bar-page-size (te-v-scroll-bar di)) (- (point-v te-size) (te-v-line-size di))))
  227.     (when (slot-boundp di 'te-h-scroll-bar)
  228.       (setf (scroll-bar-page-size (te-h-scroll-bar di)) (- (point-h te-size) (te-h-line-size di)))))
  229.   (invalidate-view di t))
  230.  
  231. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  232.  
  233. (defmethod cut ((di te-dim))
  234.   (unless (te-read-only-p di)
  235.     (with-focused-view (focusing-view di)
  236.       (te-cut (te-blob di)))))
  237.  
  238. (defmethod copy ((di te-dim))
  239.   (te-copy (te-blob di)))
  240.  
  241. (defmethod clear ((di te-dim))
  242.   (unless (te-read-only-p di)
  243.     (with-focused-view (focusing-view di)
  244.       (te-clear (te-blob di)))))
  245.  
  246. (defmethod paste ((di te-dim))
  247.   (unless (te-read-only-p di)
  248.     (with-focused-view (focusing-view di)
  249.       (te-paste (te-blob di)))))
  250.  
  251. (defmethod select-all ((di te-dim))
  252.   (with-focused-view (focusing-view di)
  253.     (te-select-all (te-blob di))))
  254.  
  255. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  256.  
  257. (defmethod te-margins ((di te-dim))
  258.   (declare (ignore di))
  259.   (values #@(0 0) #@(0 0)))
  260.  
  261. (defmethod te-corners ((di te-dim))
  262.   (multiple-value-bind (topLeft botRight) (focused-corners di)
  263.     (multiple-value-bind (tl-margin br-margin) (te-margins di)
  264.       (values (add-points topLeft tl-margin) (subtract-points botRight br-margin)))))
  265.  
  266. (defmethod view-draw-contents :after ((di te-dim))
  267.   (te-draw (te-blob di)))
  268.  
  269. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  270.  
  271. (defmethod scroll-bar-changed ((di te-dim) scroll-bar)
  272.   (ecase (ccl::scroll-bar-direction scroll-bar)
  273.     (:vertical
  274.      (setf (te-v-scroll-value (te-blob di)) (scroll-bar-setting scroll-bar)))
  275.     (:horizontal
  276.      (setf (te-h-scroll-value (te-blob di)) (scroll-bar-setting scroll-bar)))))
  277.  
  278. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  279.  
  280. (defmethod te-set-font ((di te-dim) font-spec &key (font-color *black-color*) (mode #$doAll))
  281.   (with-focused-view (focusing-view di)
  282.     (te-set-font (te-blob di) font-spec :font-color font-color :mode mode)))
  283.  
  284. (defmethod te-selection ((di te-dim))
  285.   (with-focused-view (focusing-view di)
  286.     (te-selection (te-blob di))))
  287.  
  288. (defmethod te-set-selection ((di te-dim) sel-start sel-end)
  289.   (with-focused-view (focusing-view di)
  290.     (te-set-selection (te-blob di) sel-start sel-end)))
  291.  
  292. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  293.  
  294. (defmethod dialog-item-text ((di te-dim))
  295.   (te-string (te-blob di)))
  296.  
  297. (defmethod set-dialog-item-text ((di te-dim) string)
  298.   (with-focused-dialog-item (di)
  299.     (setf (te-string (te-blob di)) string)))
  300.  
  301. (defmethod set-dialog-item-text :after ((di te-dim) string)
  302.   (declare (ignore string))
  303.   (invalidate-view di t))
  304.  
  305. (defmethod te-string ((di te-dim))
  306.   (dialog-item-text di))
  307.  
  308. (defmethod (setf te-string) (string (di te-dim))
  309.   (set-dialog-item-text di string))
  310.  
  311. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  312.  
  313. #|
  314.  
  315. (open-res-file "oou:examples;examples.rsrc")
  316.  
  317. (defclass te (te-dim dialog-item) ())
  318.  
  319. (defparameter *test-w* (make-instance 'window
  320.                          :view-size #@(250 250)
  321.                          :view-subviews
  322.                          (list
  323.                           (make-instance 'scroll-bar-dialog-item
  324.                             :view-position #@(5 5)
  325.                             :view-size #@(16 100)
  326.                             :view-nick-name :vsb)
  327.                           (make-instance 'te 
  328.                             :te-init-rsrc "example style text"
  329.                             :view-position #@(30 5)
  330.                             :view-size #@(200 100)
  331.                             :view-nick-name :te
  332.                             :allow-returns t
  333.                             :te-word-wrap-p t
  334.                             :te-v-scroll-bar :vsb
  335.                             )
  336.                           )))
  337.  
  338.  
  339.  
  340. ;change the font attrs of current selection
  341. (te-set-font (view-named :te *test-w*)
  342.              '("Times" 18 :shadow) :font-color *red-color*)
  343.  
  344. (close-res-file "oou:examples;examples.rsrc")
  345.  
  346.  
  347. |#