home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / source / oodleutl.cpt / oodles-of-utils / objects-of-desire / te-blob.lisp < prev   
Encoding:
Text File  |  1992-07-15  |  13.3 KB  |  415 lines
  1. (in-package :oou)
  2. (oou-provide :te-blob)
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;; te-blob.lisp
  5. ;;
  6. ;; Copyright ⌐ 1992 Northwestern University Institute for the Learning Sciences
  7. ;; All Rights Reserved
  8. ;;
  9. ;; author: Michael S. Engber
  10. ;;
  11. ;; styled text edit object
  12. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13.  
  14. (oou-dependencies :QuickDraw-u
  15.                   :records-u)
  16.  
  17. ;;currently I haven't documented and exported this thing. I'm reserving the
  18. ;; right to make signicant changes.
  19. ;;te-svm makes use of it.
  20.  
  21. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22.  
  23. (defCcallable te-clik-loop (:word)
  24.   (declare (special *te-current-blob*))
  25.   (declare (special *te-view-rect*))
  26.   (te-click-loop *te-current-blob*)
  27.   (#_ClipRect *te-view-rect*))
  28.  
  29.  
  30. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  31.  
  32. (defclass te-blob ()
  33.   ((te-hTE :accessor te-hTE)
  34.    (te-max-v-scroll    :accessor te-max-v-scroll)
  35.    (te-max-h-scroll    :accessor te-max-h-scroll
  36.                        :initform 1000)
  37.    (te-v-scroll-p      :initarg :te-v-scroll-p
  38.                        :accessor te-v-scroll-p)
  39.    (te-h-scroll-p      :initarg :te-h-scroll-p
  40.                        :accessor te-h-scroll-p)
  41.    (te-scroll-value-fn :initarg :te-scroll-value-fn
  42.                        :accessor te-scroll-value-fn)
  43.    (te-scroll-limit-fn :initarg :te-scroll-limit-fn
  44.                        :accessor te-scroll-limit-fn)
  45.    )
  46.   (:default-initargs
  47.     :te-topLeft     #@(0 0)
  48.     :te-botRight    #@(100 100)
  49.     :te-just        :default
  50.     :te-word-wrap-p nil
  51.     :te-v-scroll-p  nil
  52.     :te-h-scroll-p  nil   
  53.     ))
  54.  
  55.  
  56. (defmethod initialize-instance :after ((te te-blob) &rest initargs
  57.                                        &key
  58.                                        te-port
  59.                                        te-topLeft
  60.                                        te-botRight
  61.                                        te-just
  62.                                        te-word-wrap-p)
  63.   (declare (ignore initargs))
  64.   (rlet ((r :Rect
  65.             :topLeft     te-topLeft
  66.             :bottomRight te-botRight))
  67.     (with-port te-port
  68.         (setf (te-hTE te) (#_TEStylNew r r))))
  69.   (#_TEAutoView t (te-hTE te))
  70.   (hset (te-hTE te) :TERec.clikLoop te-clik-loop)
  71.   (#_TESetJust (ecase te-just
  72.                  (:default #$teFlushDefault)
  73.                  (:center  #$teCenter)
  74.                  (:right   #$teFlushRight)
  75.                  (:left    #$teFlushLeft))
  76.    (te-hTE te))
  77.   (hset (te-hTE te) :TERec.crOnly (if te-word-wrap-p 0 -1)))
  78.  
  79. (defmethod te-free ((te te-blob))
  80.   (#_TEDispose (te-hTE te))
  81.   (slot-makunbound te 'te-hTE))
  82.  
  83. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  84.  
  85. (defmethod te-draw ((te te-blob))
  86.   (multiple-value-bind (topLeft botRight) (te-corners te)
  87.     (rlet ((r :Rect
  88.               :topLeft     topLeft
  89.               :bottomRight botRight))
  90.       (#_TEUpdate  r (te-hTE te)))))
  91.  
  92.  
  93. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  94. ;;vertical scrolling
  95.  
  96. (defmethod te-calc-max-v-scroll ((te te-blob))
  97.   (with-macptrs ((hTE (te-hTE te)))
  98.     (setf (te-max-v-scroll te)
  99.           (- (#_TEGetHeight 1 65535 hTE)
  100.              (- (href hTE :TERec.viewRect.bottom) (href hTE :TERec.viewRect.top))))))
  101.  
  102. (defmethod te-v-scroll-value ((te te-blob))
  103.   (with-macptrs ((hTE (te-hTE te)))
  104.     (- (href hTE :TERec.viewRect.top) (href hTE :TERec.destRect.top))))
  105.  
  106. (defmethod (setf te-v-scroll-value) (new-scroll-value (te te-blob))
  107.   (prog1
  108.     (setf new-scroll-value (max 0 (min new-scroll-value (te-max-v-scroll te))))
  109.     (#_TEScroll 0 (- (te-v-scroll-value te) new-scroll-value) (te-hTE te))
  110.     (te-update-scroll-value te :vertical)))
  111.  
  112. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  113. ;;horizontal scrolling
  114.  
  115. (defmethod te-calc-max-h-scroll ((te te-blob))
  116.   (te-max-h-scroll te))
  117.  
  118. (defmethod te-h-scroll-value ((te te-blob))
  119.   (with-macptrs ((hTE (te-hTE te)))
  120.     (- (href hTE :TERec.viewRect.left) (href hTE :TERec.destRect.left))))
  121.  
  122. (defmethod (setf te-h-scroll-value) (new-scroll-value (te te-blob))
  123.   (prog1
  124.     (setf new-scroll-value (max 0 (min new-scroll-value (te-max-h-scroll te))))
  125.     (#_TEScroll (- (te-h-scroll-value te) new-scroll-value) 0 (te-hTE te))
  126.     (te-update-scroll-value te :horizontal)))
  127.  
  128. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  129.  
  130. (defmethod te-update-scroll-value ((te te-blob) direction)
  131.   (when (slot-boundp te 'te-scroll-value-fn)
  132.     (ecase direction
  133.       (:vertical
  134.        (funcall (te-scroll-value-fn te) :vertical   (te-v-scroll-value te)))
  135.       (:horizontal
  136.        (funcall (te-scroll-value-fn te) :horizontal (te-h-scroll-value te))))))
  137.  
  138. (defmethod te-update-scroll-limit ((te te-blob) direction)
  139.   (when (slot-boundp te 'te-scroll-limit-fn)
  140.     (ecase direction
  141.       (:vertical
  142.        (te-calc-max-v-scroll te)
  143.        (funcall (te-scroll-limit-fn te) :vertical (te-max-v-scroll te)))
  144.       (:horizontal
  145.        (te-calc-max-h-scroll te)
  146.        (funcall (te-scroll-limit-fn te) :horizontal (te-max-h-scroll te))))))
  147.  
  148. (defmethod te-update ((te te-blob))
  149.   (#_TECalText (te-hTE te))
  150.   (te-update-scroll-limit te :vertical)
  151.   (te-update-scroll-value te :vertical)
  152.   (te-update-scroll-limit te :horizontal)
  153.   (te-update-scroll-value te :horizontal))
  154.  
  155. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  156.  
  157.  
  158. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  159. ;;text position
  160.  
  161. (defmethod te-corners ((te te-blob))
  162.   (with-macptrs ((hTE (te-hTE te)))
  163.     (values (href hTE :TERec.viewRect.topLeft) (href hTE :TERec.viewRect.botRight))))
  164.  
  165. (defmethod set-te-corners ((te te-blob) topLeft botRight)
  166.   (with-macptrs ((hTE (te-hTE te)))
  167.     (multiple-value-bind (old-tl old-br) (te-corners te)
  168.       (let ((d-tl (subtract-points (href hTE :TERec.destRect.topLeft)  old-tl))
  169.             (d-br (subtract-points (href hTE :TERec.destRect.botRight) old-br)))
  170.         (hset hTE :TERec.viewRect.topLeft  topLeft)
  171.         (hset hTE :TERec.viewRect.botRight botRight)
  172.         (hset hTE :TERec.destRect.topLeft  (add-points topLeft  d-tl))
  173.         (hset hTE :TERec.destRect.botRight (add-points botRight d-br)))
  174.       (te-update te)
  175.       (values topLeft botRight))))
  176.  
  177. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  178. ;;text font
  179.  
  180. (defmethod te-set-font ((te te-blob) font-spec &key (font-color *black-color*) (mode #$doAll))
  181.   (multiple-value-bind (ff ms) (font-codes font-spec)
  182.     (rlet ((ts :TextStyle
  183.                :tsFont        (#_HiWord ff)
  184.                :tsFace        (ash (#_LoWord ff) -8)
  185.                :tsSize        (#_LoWord ms)
  186.                :tsColor.red   (color-red font-color)
  187.                :tsColor.green (color-green font-color)
  188.                :tsColor.blue  (color-blue font-color)))
  189.       (#_TESetStyle mode ts t (te-hTE te))
  190.       (#_TESelView (te-hTE te))))
  191.   (te-update te)
  192.   font-spec)
  193.  
  194. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  195. ;;text justification
  196.  
  197. (defmethod te-just ((te te-blob))
  198.   (ecase (href (te-hTE te) :TERec.just)
  199.     (#.#$teFlushDefault :default)
  200.     (#.#$teCenter       :center)
  201.     (#.#$teFlushRight   :right)
  202.     (#.#$teFlushLeft    :left)))
  203.  
  204. (defmethod (setf te-just) (new-te-just (te te-blob))
  205.   (#_TESetJust
  206.    (ecase new-te-just
  207.      (:default #$teFlushDefault)
  208.      (:center  #$teCenter)
  209.      (:right   #$teFlushRight)
  210.      (:left    #$teFlushLeft))
  211.    (te-hTE te))
  212.   (te-update te)
  213.   new-te-just)
  214.  
  215.  
  216. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  217. ;;word wrap
  218.  
  219. (defmethod te-word-wrap-p ((te te-blob))
  220.   (ecase (href (te-hTE te) :TERec.crOnly)
  221.     (-1 nil)
  222.     ( 0 t)))
  223.  
  224. (defmethod (setf te-word-wrap-p) (wrap-p (te te-blob))
  225.   (hset (te-hTE te) :TERec.crOnly (if wrap-p 0 -1))
  226.   (te-update te)
  227.   wrap-p)
  228.  
  229.  
  230. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  231. ;; event handlers
  232.  
  233. (defmethod te-click-handler ((te te-blob) where &key (extend-p (shift-key-p)))
  234.   (let ((*te-current-blob* te))
  235.     (declare (special *te-current-blob*))
  236.     (rlet ((*te-view-rect* :Rect))
  237.       (declare (special *te-view-rect*))
  238.       (multiple-value-bind (topLeft botRight) (te-corners te)
  239.         (pset *te-view-rect* :Rect.topLeft topLeft)
  240.         (pset *te-view-rect* :Rect.botRight botRight)
  241.         (with-clip-rect *te-view-rect*
  242.           (#_TEClick where extend-p (te-hTE te)))))))
  243.  
  244. (defmethod te-key ((te te-blob) char)
  245.   (#_TESelView (te-hTE te))
  246.   (#_TEKey char (te-hTE te))
  247.   (te-update te))
  248.  
  249. (defmethod te-idle ((te te-blob))
  250.   (#_TEIdle (te-hTE te)))
  251.  
  252. (defmethod te-activate ((te te-blob))
  253.   (#_TEActivate (te-hTE te)))
  254.  
  255. (defmethod te-deactivate ((te te-blob))
  256.   (#_TEDeactivate (te-hTE te)))
  257.  
  258.  
  259. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  260. ;; editing commands
  261.  
  262. (defmethod te-cut ((te te-blob))
  263.   (#_TESelView (te-hTE te))
  264.   (#_TECut (te-hTE te))
  265.   (te-update te))
  266.  
  267. (defmethod te-copy ((te te-blob))
  268.   (#_TESelView (te-hTE te))
  269.   (#_TECopy (te-hTE te)))
  270.  
  271. (defmethod te-paste ((te te-blob))
  272.   (#_TESelView (te-hTE te))
  273.   (#_TEStylPaste (te-hTE te))
  274.   (te-update te))
  275.  
  276. (defmethod te-clear ((te te-blob))
  277.   (#_TESelView (te-hTE te))
  278.   (#_TEDelete (te-hTE te))
  279.   (te-update te))
  280.  
  281.  
  282. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  283. ;; selection commands
  284.  
  285. (defmethod te-select-all ((te te-blob))
  286.   (#_TESetSelect 0 65535 (te-hTE te)))
  287.  
  288. (defmethod te-selection ((te te-blob))
  289.   (with-macptrs ((hTE (te-hTE te)))
  290.     (values (href hTE :TERec.selStart) (href hTE :TERec.selEnd))))
  291.  
  292. (defmethod te-set-selection ((te te-blob) sel-start sel-end)
  293.   (#_TESetSelect sel-start sel-end (te-hTE te))
  294.   (values sel-start sel-end))
  295.  
  296. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  297.  
  298. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  299. ;;setting text via LISP strings
  300.  
  301. (defmethod te-string ((te te-blob))
  302.   (with-macptrs ((hTE (te-hTE te)))
  303.     (with-dereferenced-handles  ((text-ptr (#_TEGetText hTE)))
  304.       (ccl::%str-from-ptr text-ptr (href hTE :TERec.teLength)))))
  305.  
  306. (defmethod (setf te-string) (new-string (te te-blob))
  307.   (with-cstrs ((cstr new-string))
  308.     (#_TESetText cstr (length new-string) (te-hTE te)))
  309.   (te-set-selection te 0 0)
  310.   (te-update-scroll-limit te :vertical)
  311.   (te-update-scroll-limit te :horizontal)
  312.   (setf (te-v-scroll-value te) 0)
  313.   (setf (te-h-scroll-value te) 0)
  314.   (te-draw te)
  315.   new-string)
  316.  
  317.  
  318. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  319. ;;setting text via TEXT and styl handles
  320.  
  321. (defmethod te-text-handle ((te te-blob))
  322.   (rlet ((handle-ptr :handle (href (te-hTE te) :TERec.hText)))
  323.     (#_HandToHand handle-ptr)
  324.     (%get-ptr handle-ptr)))
  325.  
  326. (defmethod te-style-handle ((te te-blob))
  327.   (with-macptrs ((hTE (te-hTE te)))
  328.     (multiple-value-bind (start end) (te-selection te)
  329.       (te-deactivate te)
  330.       (te-select-all te)
  331.       (prog1
  332.         (#_GetStylScrap hTE)
  333.         (te-set-selection te start end)
  334.         (te-activate te)))))
  335.  
  336. (defmethod te-handles ((te te-blob))
  337.   (values (te-text-handle te) (te-style-handle te)))
  338.  
  339. (defmethod (setf te-text-handle) (text-handle (te te-blob))
  340.   (with-dereferenced-handles ((text-ptr text-handle))
  341.     (#_TESetText text-ptr (#_GetHandleSize text-handle) (te-hTE te)))
  342.   (te-set-selection te 0 0)
  343.   (te-update te)
  344.   text-handle)
  345.  
  346. (defmethod (setf te-style-handle) (style-handle (te te-blob))
  347.   (with-macptrs ((hTE (te-hTE te)))
  348.     (#_SetStylScrap 0 (href hTE :TERec.teLength) style-handle nil hTE))
  349.   (te-set-selection te 0 0)
  350.   (te-update te)
  351.   style-handle)
  352.  
  353. (defmethod set-te-handles ((te te-blob) text-handle style-handle)
  354.   (with-macptrs ((hTE (te-hTE te)))
  355.     (when text-handle
  356.       (with-dereferenced-handles ((text-ptr text-handle))
  357.         (#_TESetText text-ptr (#_GetHandleSize text-handle) hTE)))
  358.     (when style-handle
  359.       (#_SetStylScrap 0 (href hTE :TERec.teLength) style-handle nil hTE))
  360.     (te-set-selection te 0 0)
  361.     (te-update te)
  362.     (values text-handle style-handle)))
  363.  
  364. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  365. ;; scrolling
  366.  
  367. (defmethod te-click-loop ((te te-blob))
  368.   (rlet ((pt_p :point))
  369.     (#_GetMouse pt_p)
  370.     (let ((v (%get-signed-word pt_p))
  371.           (h (%get-signed-word pt_p 2)))
  372.       (with-dereferenced-handles ((pTE (te-hTE te)))
  373.         (when (te-v-scroll-p te)
  374.           (if (< v (pref pTE :TERec.viewRect.top))
  375.             (te-line-down te)
  376.             (when (> v (pref pTE :TERec.viewRect.bottom))
  377.               (te-line-up te))))
  378.         (when (te-h-scroll-p te)
  379.           (if (< h (pref pTE :TERec.viewRect.left))
  380.             (te-line-right te)
  381.             (when (> h (pref pTE :TERec.viewRect.right))
  382.               (te-line-left te))))))))
  383.  
  384. (defmethod te-line-up ((te te-blob))
  385.   (incf (te-v-scroll-value te) 5))
  386.  
  387. (defmethod te-line-down ((te te-blob))
  388.   (decf (te-v-scroll-value te) 5))
  389.  
  390. (defmethod te-v-page-size ((te te-blob))
  391.   (with-macptrs ((hTE (te-hTE te)))
  392.     (- (href hTE :TERec.viewRect.bottom) (href hTE :TERec.viewRect.top))))
  393.  
  394. (defmethod te-page-up ((te te-blob))
  395.   (incf (te-v-scroll-value te) (te-v-page-size te)))
  396.  
  397. (defmethod te-page-down ((te te-blob))
  398.   (decf (te-v-scroll-value te) (te-v-page-size te)))
  399.  
  400.  
  401. (defmethod te-line-left ((te te-blob))
  402.   (incf (te-h-scroll-value te) 5))
  403.  
  404. (defmethod te-line-right ((te te-blob))
  405.   (decf (te-h-scroll-value te) 5))
  406.  
  407. (defmethod te-h-page-size ((te te-blob))
  408.   (with-macptrs ((hTE (te-hTE te)))
  409.     (- (href hTE :TERec.viewRect.right) (href hTE :TERec.viewRect.left))))
  410.  
  411. (defmethod te-page-left ((te te-blob))
  412.   (incf (te-h-scroll-value te) (te-h-page-size te)))
  413.  
  414. (defmethod te-page-right ((te te-blob))
  415.   (decf (te-h-scroll-value te) (te-h-page-size te)))