[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Printing Interface Tools Objects
- To: info-macl@cambridge.apple.com
- Subject: Printing Interface Tools Objects
- From: LAu@a.darpa.mil
- Date: Fri, 9 Aug 91 11:54:00 EST
- Cc: LAu@a.darpa.mil
A number of MCL users have expressed an interest in high-level support
to print interface tools objects. It would be very nice to just pulldown
the File menu and select print.
The code to do this is not difficult to write, and it would greatly enhance
the rapid-prototyping abilities of MCL because hardcopy is a great way to get
people to agree on the look and feel of a window design.
I've been playing with some code passed on to me by David Hirsch at
Price Waterhouse, and with some minor enhancements I think it would be a good
thing to stash in the /pub/MCL2/contrib directory. It needs to be able to
print out more than one page, and to handle the other dialog-item types such
as radio button, sequence, and array. Perhaps we could put the code out
there, and people could just add these enhancements and re-publish the code.
Lawrence Au
Here's the code:
(in-package :ccl)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;hardcopy.lisp
;;
;;
;;copyright 1988-89 Apple Computer, Inc.
;;
;; defines a very basic printing routine for windows
;;
;; Code taken from Apple and Bill Kornfeld and played with a bit to get
;; something working. Trying to change the wptr and
;; then doing a view-draw-contents fails --- LISP unexpextantly quits.
;; View-draw-contents without changing the window pointer
;; cases a print job to be sent to the printer but nothing comes out. Using a
;; print-contents function that just makes the
;; appropriate quickdraw calls seems to wrork ok. The basic print-contents
;; functions for text, views and windows is defined
;; here. Some extra print-contents functions for other items is defined in
;; odin-printing.lisp -- DEH 6/20/91
;;;*logical-directory-alist*
(load (probe-file "library;records.lisp"))
(load (probe-file "library;traps.lisp"))
(defconstant $PrintErr #x944)
(defconstant $prJob.bJDocLoop (+ 62 6))
(defconstant $iPrStatSize 26)
(defconstant $bSpoolLoop 1)
(defconstant $err-printer 94)
(defconstant $err-printer-load 95)
(defconstant $err-printer-start 97)
(load (probe-file "interfaces;types.lisp"))
(load (probe-file "interfaces;quickdraw.lisp"))
(load (probe-file "library;quickdraw.lisp"))
;;; load for DEH's environment
#|
(eval-when (eval compile)
(require 'traps)
(require 'records)
(defconstant $PrintErr #x944)
(defconstant $prJob.bJDocLoop (+ 62 6))
(defconstant $iPrStatSize 26)
(defconstant $bSpoolLoop 1)
(defconstant $err-printer 94)
(defconstant $err-printer-load 95)
(defconstant $err-printer-start 97)
(require :quickdraw)
)
|#
(defun prchk (&optional (errnum $err-printer)
&aux (print-error (%get-signed-word (%int-to-ptr
$PrintErr))))
(unless (zerop print-error)
(ccl::%signal-error errnum print-error))
)
;;using these causes all types of bad things
;; (especially -- LISP unexpectingly quit!)
#|
(defmethod set-view-wptr ((v view) new-wptr)
(setf (wptr v) new-wptr)
(let ((subviews (view-subviews v)))
(dotimes (index (length subviews))
(set-view-wptr (aref subviews index) new-wptr))))
(defmethod set-view-wptr ((v simple-view) new-wptr)
(setf (wptr v) new-wptr))
|#
(defmethod print-schedule ((w window))
(unwind-protect
(with-cursor *arrow-cursor*
(_PrOpen)
(prchk $err-printer-load)
(let ((pRec (get-print-record)))
(when (and (_PrStlDialog :ptr pRec :boolean)
(_PrJobDialog :ptr pRec :boolean))
(let ((*hc-page-open-p* nil) (ccl::*inhibit-error* t) err)
;_PrOpenDoc puts up a dialog window which causes the event system
;to get confused. So we do the whole thing without interrupts, and
;make sure to clean up before handling errors.
(declare (special *hc-page-open-p* ccl::*inhibit-error*))
(setq err (progn ;catch-error-quietly
(without-interrupts
(let (;;(window-ptr (wptr w))
(hardcopy-ptr (_PrOpenDoc :ptr pRec :ptr
(%null-ptr) :ptr (%null-ptr) :ptr)))
(with-port hardcopy-ptr
(unwind-protect
(with-dereferenced-handles ((ppRec pRec))
pprec
(prchk $err-printer-start)
(unwind-protect
(progn
;;(set-view-wptr w hardcopy-ptr)
(_PrOpenPage :ptr hardcopy-ptr
:ptr (%null-ptr))
(with-port hardcopy-ptr
;;(ccl::with-rectangle-arg (r 10 10 200 200) (#_FrameRect r))
;;this works - for a test
;;(view-draw-contents w)
;;this either does nothing of if change wptr crashes lisp
(print-contents w)
)
(_PrClosPage :ptr hardcopy-ptr))
;; (set-view-wptr w window-ptr)
))
(_PrClosDoc :ptr hardcopy-ptr))))
;;; end of let
(when t
;;(eq (%hget-byte pRec $prJob.bJDocLoop)
;;this test always seems to fail???!!!!
;;$bSpoolLoop)
;;(format t "~%Docloop ~S" (%hget-byte pRec $prJob.bJDocLoop))
(prchk)
(%stack-block ((StRec $iPrStatSize))
(_PrPicFile :ptr pRec
:ptr (%null-ptr)
:ptr (%null-ptr)
:ptr (%null-ptr)
:ptr StRec))
(prchk)))))
;;; end of setq err
t))))
;;; end of with-cursor *arrow-cursor*
(_PrClose))
)
;;unfortunately, this doesn't work for dialogs
#|
(defobfun (window-hardcopy *dialog*) ()
(message-dialog "Cannot print of dialogs at this time"))
|#
;;; version 1.3.2 test code
#|
(require 'quickdraw)
(setq foo (oneof *window*))
(defobfun (view-draw-contents foo) ()
(frame-rect 10 10 100 100)
(usual-view-draw-contents))
(setq bar (oneof *view*
:view-container foo
:view-position #@(150 150)))
(defobfun (view-draw-contents bar) ()
(paint-oval 10 10 100 100)
(usual-view-draw-contents))
(ask foo (window-hardcopy))
|#
;;;------------------ The basic print-contents functions----------------------
(defmethod print-contents ((v window))
"a window draws a box around itself and
then asks its subviews to print themselves"
(let ((size (view-size v))
(top 0)
(left 0)
bottom right)
(setq bottom (+ top (point-v size))
right (+ left (point-h size)))
;;first frame it
(ccl::with-rectangle-arg (r left top right bottom) (#_FrameRect r))
(dovector (sv (view-subviews v))
(print-contents sv)))
)
(defmethod print-contents ((v view))
"a view just asks its subviews to print themselves"
(dovector (sv (view-subviews v))
(print-contents sv)))
(defmethod print-contents ((sv ccl::basic-editable-text-dialog-item))
"editable text uses textbox -- take into account font and the justification"
(let ((window (view-window sv))
(container (view-container sv))
(pos (view-position sv))
(size (view-size sv))
cpos
top left bottom right
font-face mode-size)
(multiple-value-setq (font-face mode-size)
(view-font-codes sv))
(setq cpos (convert-coordinates pos container window))
(setq top (point-v cpos)
left (point-h cpos))
(setq bottom (+ top (point-v size))
right (+ left (point-h size)))
(with-font-codes font-face mode-size
(ccl::with-rectangle-arg (r left top right bottom)
(with-pstrs ((pstring (dialog-item-text sv)))
(_TextBox :ptr (%inc-ptr pstring 1)
:long (length (dialog-item-text sv))
:ptr r
:word (slot-value sv 'ccl::text-justification)))))))
(defmethod print-contents ((sv static-text-dialog-item))
"static text uses textbox -- take into account font and the justification"
(let ((window (view-window sv))
(container (view-container sv))
(pos (view-position sv))
(size (view-size sv))
cpos
top left
bottom right
font-face mode-size)
(multiple-value-setq (font-face mode-size)
(view-font-codes sv))
(setq cpos (convert-coordinates pos container window))
(setq top (point-v cpos)
left (point-h cpos))
(setq bottom (+ top (point-v size))
right (+ left (point-h size)))
(with-font-codes font-face mode-size
(ccl::with-rectangle-arg (r left top right bottom)
(with-pstrs ((pstring (dialog-item-text sv)))
(_TextBox :ptr (%inc-ptr pstring 1)
:long (length (dialog-item-text sv))
:ptr r
:word (slot-value sv 'ccl::text-justification)))))))
(defmethod print-contents ((sv button-dialog-item))
(let ((window (view-window sv))
(container (view-container sv))
(pos (view-position sv))
(size (view-size sv))
cpos
top left bottom right
font-face mode-size)
(multiple-value-setq (font-face mode-size)
(view-font-codes sv))
(setq cpos (convert-coordinates pos container window))
(setq top (point-v cpos)
left (point-h cpos))
(setq bottom (+ top (point-v size))
right (+ left (point-h size)))
(ccl::with-rectangle-arg (r left top right bottom)
(with-font-codes font-face mode-size
(with-pstrs ((pstring (dialog-item-text sv)))
(_TextBox :ptr (%inc-ptr pstring 1)
:long (length (dialog-item-text sv))
:ptr r :word 1)))
;;; end of with-font-codes
(rlet ((old-pen-state :penstate) (new-pen-state :penstate))
(_GetPenState :ptr old-pen-state)
(rset new-pen-state :penstate.pnLoc
(rref old-pen-state :penState.pnLoc))
(rset new-pen-state :penstate.pnSize #@(1 1))
(rset new-pen-state :penstate.pnMode TRAPS:$PATOR)
(rset new-pen-state :penstate.pnPat *black-pattern*)
(_SetPenState :ptr new-pen-state)
;;(decf (rref r :rect.left)
;; (floor (dialog-item-width-correction sv) 2))
;;(incf (rref r :rect.right)
;; (floor (dialog-item-width-correction sv) 2))
(_FrameRoundRect :ptr r :word 10 :word 6)
(_SetPenState :ptr old-pen-state)))))
(defmethod print-contents ((sv simple-view))
"default if all else fails do nothing"
t
)
#|
(setq w (make-instance 'window
:window-title "HI there"
:view-size #@(300 300)
:view-subviews
(list (make-instance 'view
:view-position #@(20 20)
:view-size #@(150 130)
:view-subviews
(List (make-instance 'static-text-dialog-item
:view-position #@(10 10)
:view-size #@(130 40)
:view-font '("Helvetica" :srcor :bold 12)
:dialog-item-text
"how now said the big brown cow")
(make-instance 'static-text-dialog-item
:view-position #@(10 70)
:view-size #@(130 60)
:view-font '("Geneva" :srcor :underline 14)
:dialog-item-text
"there is a bunch of green cheese here on the moon"))))))
(print-schedule w)
(setf test-window
(MAKE-INSTANCE 'COLOR-DIALOG
:WINDOW-TYPE :DOCUMENT-WITH-ZOOM :VIEW-POSITION ':CENTERED
:VIEW-SIZE #@(918 708)
:VIEW-FONT '("Chicago" 12 :SRCOR :PLAIN)
:VIEW-SUBVIEWS
(LIST (MAKE-DIALOG-ITEM 'STATIC-TEXT-DIALOG-ITEM
#@(13 9)
#@(56 16)
"Untitled"
NIL)
(MAKE-DIALOG-ITEM 'EDITABLE-TEXT-DIALOG-ITEM
#@(15 25)
#@(84 16)
"Untitled"
NIL
:ALLOW-RETURNS NIL)
(MAKE-DIALOG-ITEM 'BUTTON-DIALOG-ITEM
#@(15 47)
#@(62 16)
"Untitled"
NIL
:DEFAULT-BUTTON NIL)
(MAKE-DIALOG-ITEM 'EDITABLE-TEXT-DIALOG-ITEM
#@(381 683)
#@(114 16)
"bottom center"
NIL
:ALLOW-RETURNS NIL)
(MAKE-DIALOG-ITEM 'EDITABLE-TEXT-DIALOG-ITEM
#@(11 688)
#@(84 16)
"bottom left"
NIL
:ALLOW-RETURNS NIL)
(MAKE-DIALOG-ITEM 'EDITABLE-TEXT-DIALOG-ITEM
#@(375 20)
#@(84 16)
"top center"
NIL
:ALLOW-RETURNS NIL)
(MAKE-DIALOG-ITEM 'EDITABLE-TEXT-DIALOG-ITEM
#@(799 676)
#@(84 16)
"bottom right"
NIL
:VIEW-FONT
'("New Century Schlbk"
12
:SRCOR
:PLAIN)
:ALLOW-RETURNS NIL)
(MAKE-DIALOG-ITEM 'EDITABLE-TEXT-DIALOG-ITEM
#@(818 20)
#@(84 16)
"top right"
NIL
:VIEW-FONT
'("New Century Schlbk"
12
:SRCOR
:PLAIN)
:ALLOW-RETURNS NIL)))
)
(print-schedule test-window)
|#