home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / source / oodleutl.cpt / oodles-of-utils / mixin-madness / simple-view-mixins / PICT-svm.lisp < prev    next >
Encoding:
Text File  |  1992-01-30  |  2.9 KB  |  78 lines
  1. (in-package :oou)
  2. (oou-provide :PICT-svm)
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;; PICT-svm.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 PICTs to views
  12. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13.  
  14. (oou-dependencies
  15.  :graphic-rsrc-svm
  16.  :PICT-u
  17.  :records-u)
  18.  
  19. (export '(PICT-svm set-view-PICT))
  20.  
  21. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22.  
  23. (defclass PICT-svm (graphic-rsrc-svm)
  24.   ((rsrc-id         :initarg :PICT-id)
  25.    (rsrc-name       :initarg :PICT-name)
  26.    (rsrc-handle     :initarg :PICT-handle)
  27.    (PICT-file       :initarg :PICT-file)
  28.    (PICT-storage    :initarg :PICT-storage)
  29.    (graphic-scaling :initarg :PICT-scaling))
  30.   (:default-initargs
  31.     :rsrc-type "PICT"
  32.     :PICT-storage :memory
  33.     :graphic-default-size #@(100 100)))
  34.  
  35. (defmethod rsrc-handle-install ((sv PICT-svm))
  36.   (call-next-method)
  37.   (when (and (not (slot-boundp sv 'rsrc-handle)) (slot-boundp sv 'PICT-file))
  38.     (setf (slot-value sv 'rsrc-handle)
  39.           (ecase (slot-value sv 'PICT-storage)
  40.             (:memory (get-picture-from-file (slot-value sv 'PICT-file)))
  41.             (:disk   (let ((PICT_h (#_NewHandle (rlength :Picture))))
  42.                        (when (%null-ptr-p PICT_h)
  43.                          (error "unable to allocate a ~a picture record handle (~a bytes) for ~s"
  44.                                 (rlength :Picture)
  45.                                 (slot-value sv 'PICT-file)))
  46.                        (with-dereferenced-handles ((PICT_p PICT_h))
  47.                          (get-PICT-file-info (slot-value sv 'PICT-file) PICT_p))
  48.                        PICT_h))))))
  49.  
  50. (defmethod rsrc-get-fn ((sv PICT-svm) rsrc-type rsrc-id-or-name)
  51.   (declare (ignore rsrc-type))
  52.   (etypecase rsrc-id-or-name
  53.     (fixnum (#_GetPicture rsrc-id-or-name))
  54.     (string (#_GetPicture (get-resource-id "PICT" rsrc-id-or-name)))))
  55.  
  56. (defmethod graphic-size ((sv PICT-svm) PICT-handle)
  57.   (declare (ignore sv))
  58.   (subtract-points
  59.    (href PICT-handle :Picture.picFrame.botRight)
  60.    (href PICT-handle :Picture.picFrame.topLeft )))
  61.  
  62. (defmethod draw-graphic ((sv PICT-svm) PICT-handle rect)
  63.   (ecase (slot-value sv 'PICT-storage)
  64.     (:memory (#_DrawPicture PICT-handle rect))
  65.     (:disk   (draw-picture-from-file (slot-value sv 'PICT-file) rect))))
  66.  
  67. (defmethod view-default-size ((sv PICT-svm))
  68.   (add-points (multiple-value-call #'add-points (graphic-margins sv)) #@(100 100)))
  69.  
  70. (defmethod set-view-PICT ((sv PICT-svm) &key PICT-id PICT-name PICT-handle PICT-file PICT-storage)
  71.   (when PICT-file (setf (slot-value sv 'PICT-file) PICT-file))
  72.   (when PICT-storage (setf (slot-value sv 'PICT-storage) PICT-storage))
  73.   (set-view-resource sv :rsrc-id PICT-id :rsrc-name PICT-name :rsrc-handle PICT-handle))
  74.  
  75. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  76. #|
  77.    example code can be found in PICT-di
  78. |#