home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / source / oodleutl.cpt / oodles-of-utils / objects-of-desire / room-with-a-view / te-view.lisp < prev    next >
Encoding:
Text File  |  1992-07-15  |  11.7 KB  |  285 lines
  1. (in-package :oou)
  2. (oou-provide :te-view)
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;; te-view.lisp
  5. ;;
  6. ;; Copyright ⌐ 1992 Northwestern University Institute for the Learning Sciences
  7. ;; All Rights Reserved
  8. ;;
  9. ;; author: Cliff Chaput
  10. ;;
  11. ;; View containing te-di and scrollbars
  12. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13.  
  14. (oou-dependencies :te-dim
  15.                   :draggable-svm
  16.                   :frame-svm)
  17.  
  18. (export '(te-view
  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-item (te-dim dialog-item) ())
  26.  
  27. (defclass te-view (frame-svm view)
  28.   ((te-item             :accessor te-item)
  29.    (te-v-scroll-bar     :accessor te-v-scroll-bar)
  30.    (te-h-scroll-bar     :accessor te-h-scroll-bar)
  31.    (te-v-scroll-bar-p   :initarg :te-v-scroll-bar-p
  32.                         :accessor te-v-scroll-bar-p)
  33.    (te-h-scroll-bar-p   :initarg :te-h-scroll-bar-p
  34.                         :accessor te-h-scroll-bar-p)
  35.    (te-scroll-bar-width :accessor te-scroll-bar-width
  36.                         :initarg :te-scroll-bar-width)
  37.    (te-init-string      :initarg :te-init-string
  38.                         :initarg :dialog-item-text
  39.                         :accessor te-init-string)
  40.    (te-init-rsrc        :initarg :te-init-rsrc
  41.                         :accessor te-init-rsrc)
  42.    (te-word-wrap-p      :accessor te-word-wrap-p
  43.                         :initarg :te-word-wrap-p)
  44.    (te-read-only-p      :accessor te-read-only-p
  45.                         :initarg :te-read-only-p)
  46.    (te-h-margin         :accessor te-h-margin
  47.                         :initarg :te-h-margin))
  48.   (:default-initargs
  49.     :te-init-string      "The horror╔"
  50.     :te-word-wrap-p      t
  51.     :te-read-only-p      nil
  52.     :te-v-scroll-bar-p   t
  53.     :te-h-scroll-bar-p   nil
  54.     :te-scroll-bar-width 16
  55.     :te-h-margin         1
  56.     ))
  57.  
  58.  
  59. (defmethod initialize-instance :after ((self te-view) &rest initargs)
  60.   (declare (ignore initargs))
  61.   (when (te-v-scroll-bar-p self)
  62.     (multiple-value-bind (pos width length) (v-scroll-dimensions self)
  63.       (setf (te-v-scroll-bar self)
  64.             (make-instance 'scroll-bar-dialog-item
  65.               :view-container  self
  66.               :view-position   pos
  67.               :width           width
  68.               :length          length
  69.               :view-nick-name  :te-item-v-scroll))))
  70.  
  71.   (when (te-h-scroll-bar-p self)
  72.     (multiple-value-bind (pos width length) (h-scroll-dimensions self)
  73.       (setf (te-h-scroll-bar self)
  74.             (make-instance 'scroll-bar-dialog-item
  75.               :direction      :horizontal
  76.               :view-container self
  77.               :view-position  pos
  78.               :width          length
  79.               :length         width
  80.               :view-nick-name :te-item-h-scroll))))
  81.  
  82.   (setf (te-item self) (create-te-item self)))
  83.  
  84.  
  85. (defmethod set-view-size :after ((self te-view) h &optional v)
  86.   (declare (ignore h v))
  87.  
  88.   (set-view-size (te-item self) (te-item-size self))
  89.  
  90.   (when (slot-boundp self 'te-v-scroll-bar)
  91.     (multiple-value-bind (pos width length) (v-scroll-dimensions self)
  92.       (set-view-position (te-v-scroll-bar self) pos)
  93.       (set-scroll-bar-width (te-v-scroll-bar self) width)
  94.       (set-scroll-bar-length (te-v-scroll-bar self) length)))
  95.  
  96.   (when (slot-boundp self 'te-h-scroll-bar)
  97.     (multiple-value-bind (pos width length) (h-scroll-dimensions self)
  98.       (set-view-position (te-h-scroll-bar self) pos)
  99.       (set-scroll-bar-width (te-h-scroll-bar self) length)
  100.       (set-scroll-bar-length (te-h-scroll-bar self) width))))
  101.  
  102.  
  103. (defmethod v-scroll-dimensions ((self te-view))
  104.   (values
  105.    (make-point (- (point-h (view-size self)) (te-scroll-bar-width self)) 0)
  106.    (te-scroll-bar-width self)
  107.    (if (te-h-scroll-bar-p self)
  108.      (- (point-v (view-size self)) (te-scroll-bar-width self) -1)
  109.      (point-v (view-size self)))))
  110.  
  111.  
  112. (defmethod h-scroll-dimensions ((self te-view))
  113.   (values
  114.    (make-point 0 (- (point-v (view-size self)) (te-scroll-bar-width self)))
  115.    (if (te-v-scroll-bar-p self)
  116.      (- (point-h (view-size self)) (te-scroll-bar-width self) -1)
  117.      (point-h (view-size self)))
  118.    (te-scroll-bar-width self)))
  119.  
  120.  
  121. (defmethod create-te-item ((self te-view))
  122.   (let* ((h-scroll-bar (when (te-h-scroll-bar-p self)
  123.                          (list :te-h-scroll-bar :te-item-h-scroll)))
  124.          (v-scroll-bar (when (te-v-scroll-bar-p self)
  125.                          (list :te-v-scroll-bar :te-item-v-scroll)))
  126.          (init-rsrc (when (slot-boundp self 'te-init-rsrc)
  127.                       (list :te-init-rsrc (te-init-rsrc self))))
  128.          (final-args `(,@h-scroll-bar ,@v-scroll-bar ,@init-rsrc)))
  129.     
  130.     (apply #'make-instance 'te-item
  131.            :te-init-string (te-init-string self)
  132.            :allow-returns  t
  133.            :te-word-wrap-p (te-word-wrap-p self)
  134.            :te-read-only-p (te-read-only-p self)
  135.            :view-container self
  136.            :view-position  (make-point (te-h-margin self) 1)
  137.            :view-size      (te-item-size self)
  138.            :view-nick-name :te-item
  139.            final-args)))
  140.  
  141.  
  142. (defmethod te-item-size ((self te-view))
  143.   (subtract-points (view-size self)
  144.                    (make-point
  145.                     (+ (if (te-v-scroll-bar-p self) (te-scroll-bar-width self) 0) (* 2 (te-h-margin self)))
  146.                     (+ (if (te-h-scroll-bar-p self) (te-scroll-bar-width self) 1) 1))))
  147.  
  148.  
  149. ;;;Duplicated methods that just call the same methods on the te-item
  150.  
  151. (defmethod te-save-text-rsrc ((self te-view) &key rsrc-id rsrc-name)
  152.   (te-save-text-rsrc (te-item self) :rsrc-id rsrc-id :rsrc-name rsrc-name))
  153.  
  154. (defmethod te-set-text-rsrc ((self te-view) rsrc-id-or-name)
  155.   (te-set-text-rsrc (te-item self) rsrc-id-or-name))
  156.  
  157. (defmethod te-set-font ((self te-view) font-spec &key (font-color *black-color*) (mode #$doAll))
  158.   (te-set-font (te-item self) font-spec :font-color font-color :mode mode))
  159.  
  160. (defmethod te-selection ((self te-view))
  161.   (te-selection (te-item self)))
  162.  
  163. (defmethod te-set-selection ((self te-view) sel-start sel-end)
  164.   (te-set-selection (te-item self) sel-start sel-end))
  165.  
  166. (defmethod te-string ((self te-view))
  167.   (te-string (te-item self)))
  168.  
  169. (defmethod (setf te-string) (string (self te-view))
  170.   (setf (te-string (te-item self)) string))
  171.  
  172. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  173.  
  174. #|
  175.  
  176. (open-res-file "oou:examples;examples.rsrc")
  177. ;(close-res-file "oou:examples;examples.rsrc")
  178.  
  179. (defparameter *test-w* (make-instance 'window
  180.                          :view-size #@(410 200)
  181.                          :window-title "te-view test"
  182.                          :color-p t
  183.                          :view-subviews
  184.                          (list
  185.                           (make-instance 'te-view
  186.                             :view-position      #@(5 5)
  187.                             :view-size          #@(230 175)
  188.                             :view-nick-name     :te
  189.                             :te-init-rsrc       "example style text"
  190.                             :te-v-scroll-bar-p t
  191.                             ;:te-h-scroll-bar-p t
  192.                             :te-h-margin        5
  193.                             )
  194.                           (make-instance 'pop-up-menu
  195.                             :view-position #@(240 5)
  196.                             :view-size #@(160 20)
  197.                             :auto-update-default nil
  198.                             :menu-items (font-menu-items))
  199.                           (make-instance 'pop-up-menu
  200.                             :view-position #@(240 30)
  201.                             :view-size #@(160 20)
  202.                             :auto-update-default nil
  203.                             :menu-items (size-menu-items))
  204.                           (make-instance 'pop-up-menu
  205.                             :view-position #@(240 55)
  206.                             :view-size #@(160 20)
  207.                             :auto-update-default nil
  208.                             :menu-items (style-menu-items))
  209.                           (make-instance 'pop-up-menu
  210.                             :view-position #@(240 80)
  211.                             :view-size #@(160 20)
  212.                             :auto-update-default nil
  213.                             :menu-colors '(:menu-background 5592405)
  214.                             :menu-items (color-menu-items)
  215.                             ))))
  216.  
  217. (defun font-menu-items ()
  218.   `(,(make-instance 'menu-item :menu-item-title "Da Font")
  219.     ,(make-instance 'menu-item :menu-item-title "-" :disabled t)
  220.     ,@(mapcar #'(lambda (font-name)
  221.                   (make-instance 'menu-item
  222.                     :menu-item-title font-name
  223.                     :menu-item-action #'(lambda () (te-set-font (view-named :te *test-w*)
  224.                                                                 (list font-name)
  225.                                                                 :mode #$doFont))))
  226.               *font-list*)))
  227.  
  228. (defun size-menu-items ()
  229.   `(,(make-instance 'menu-item :menu-item-title "Da Size")
  230.     ,(make-instance 'menu-item :menu-item-title "-" :disabled t)
  231.     ,@(mapcar #'(lambda (font-size)
  232.                   (make-instance 'menu-item
  233.                     :menu-item-title (format nil "~D" font-size)
  234.                     :menu-item-action #'(lambda () (te-set-font (view-named :te *test-w*)
  235.                                                                 (list font-size)
  236.                                                                 :mode #$doSize))))
  237.               '(1 7 19 37 53 71 89 107 131 151 173 193 223 239))
  238.     ,(make-instance 'menu-item :menu-item-title "-" :disabled t)
  239.     ,(make-instance 'menu-item
  240.        :menu-item-title "Smaller"
  241.        :menu-item-action #'(lambda () (te-set-font (view-named :te *test-w*)
  242.                                                    '(-1)
  243.                                                    :mode #$addSize)))
  244.     ,(make-instance 'menu-item
  245.        :menu-item-title "Larger"
  246.        :menu-item-action #'(lambda () (te-set-font (view-named :te *test-w*)
  247.                                                    '(1)
  248.                                                    :mode #$addSize)))))
  249.  
  250.  
  251. (defun style-menu-items ()
  252.   `(,(make-instance 'menu-item :menu-item-title "De Style")
  253.     ,(make-instance 'menu-item :menu-item-title "-" :disabled t)
  254.     ,@(mapcar #'(lambda (style)
  255.                   (make-instance 'menu-item
  256.                     :menu-item-title (string-capitalize style)
  257.                     :style style
  258.                     :menu-item-action #'(lambda () (te-set-font (view-named :te *test-w*)
  259.                                                                 (list style)
  260.                                                                 :mode #$doFace))))
  261.               (mapcar #'car *style-alist*))))
  262.  
  263. (defun color-menu-items ()
  264.   `(,(make-instance 'menu-item :menu-item-title "De Color")
  265.     ,(make-instance 'menu-item :menu-item-title "-" :disabled t)
  266.     ,@(mapcar #'(lambda (color)
  267.                   (make-instance 'menu-item
  268.                     :menu-item-title "≡≡≡≡≡≡≡"
  269.                     :menu-item-colors (list :item-title color)
  270.                     :menu-item-action #'(lambda () (te-set-font (view-named :te *test-w*)
  271.                                                                 nil
  272.                                                                 :font-color (eval color)
  273.                                                                 :mode #$doColor))))
  274.               '(720865 16741646 659455 16713464 16713989 524040 16776970))
  275.     ,(make-instance 'menu-item
  276.        :menu-item-title "-"
  277.        :disabled t)
  278.     ,(make-instance 'menu-item
  279.        :menu-item-title "Pick a color"
  280.        :menu-item-action #'(lambda () (te-set-font (view-named :te *test-w*)
  281.                                                    nil
  282.                                                    :font-color (user-pick-color)
  283.                                                    :mode #$doColor)))))
  284.  
  285. |#