(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "TDG")

(il:filecreated "15-Nov-88 17:38:26" il:{qv}<idl>next>twod-graphics.\;17
 21267  

      il:|changes| il:|to:|  (il:functions setf-window-method setf-window-prop setf-menu-prop)

      il:|previous| il:|date:| "30-Aug-88 18:31:33" il:{qv}<idl>next>twod-graphics.\;16)


; Copyright (c) 1988 by Xerox Corporation.  All rights reserved.

(il:prettycomprint il:twod-graphicscoms)

(il:rpaqq il:twod-graphicscoms ((il:coms (il:* il:|;;| "positions") (il:functions make-position copy-position position-p position-x position-y)) (il:coms (il:* il:|;;| "regions") (il:functions make-region copy-region region-p region-left region-right region-bottom region-top region-width region-height) (il:functions subregion-p intersect-regions) (il:functions inside-p)) (il:coms (il:* il:|;;| "display streams") (il:functions stream-clipping-region stream-scale stream-x stream-y) (il:functions boole-to-op) (il:functions stream-bitblt stream-bltshade stream-draw-line stream-draw-to stream-move-to stream-relative-move-to stream-reset) (il:functions stream-string-region) (il:functions stream-scroll setf-stream-scroll stream-texture stream-font stream-margin setf-stream-margin stream-line-feed) (il:setfs stream-scroll stream-font stream-margin)) (il:coms (il:* il:|;;| "bitmaps  ") (il:functions make-bitmap bitmap-p bitmap-width bitmap-height)) (il:coms (il:* il:|;;| "windows   ") (il:setfs il:windowprop) (il:functions make-window window-p window-width window-height window-region window-title window-border window-dsp window-icon shrunken-window-p) (il:functions window-method-to-prop window-method setf-window-method add-window-method delete-window-method) (il:setfs window-method) (il:functions window-prop setf-window-prop add-window-prop delete-window-prop) (il:setfs window-prop) (il:functions open-window-p open-window close-window to-top-window clear-window move-window redisplay-window reshape-window invert-window expand-window) (il:* il:|;;| "metric properties") (il:functions width-if-window height-if-window) (il:functions window-min-size main-window-min-size window-max-size) (il:* il:|;;| "attached-windows") (il:functions main-window attached-windows attach-window attach-menu detach-window detach-all-windows) (il:* il:|;;| "misc window fns") (il:functions print-prompt get-position get-region position-region)) (il:coms (il:* il:|;;| "cursor and mouse") (il:functions window-cursor) (il:functions mouse-state-p last-mouse-state-p until-mouse-state get-mouse-state) (il:functions last-mouse-x last-mouse-y)) (il:coms (il:* il:|;;| "menus") (il:functions normalize-subitems) (il:functions make-menu menu-p copy-menu menu-items menu-when-selected-fn) (il:functions pop-up-menu window-from-menu) (il:functions menu-prop setf-menu-prop) (il:setfs menu-prop)) (il:coms (il:* il:|;;| "fonts and display metrics") (il:functions make-interlisp make-keyword) (il:functions make-font coerce-font font-p font-family font-size font-face font-ascent font-descent font-height) (il:functions default-font) (il:functions char-code-width char-width string-width string-region)) (il:coms (il:* il:|;;| "Common variables") (il:variables *black-shade* *white-shade* *gray-shade*)) (xcl:file-environments "TWOD-GRAPHICS")))



(il:* il:|;;| "positions")



(defmacro make-position (&optional (x 0) (y 0)) (il:bquote (il:|create| il:position il:xcoord il:_ (il:\\\, x) il:ycoord il:_ (il:\\\, y))))

(defmacro copy-position (position) (il:bquote (copy-tree (il:\\\, position))))

(defmacro position-p (object) (il:bquote (il:positionp (il:\\\, object))))

(defmacro position-x (object) (il:bquote (il:|fetch| (il:position il:xcoord) il:|of| (il:\\\, object))))

(defmacro position-y (object) (il:bquote (il:|fetch| (il:position il:ycoord) il:|of| (il:\\\, object))))



(il:* il:|;;| "regions")



(defmacro make-region (left bottom width height) (il:bquote (il:createregion (il:\\\, left) (il:\\\, bottom) (il:\\\, width) (il:\\\, height))))

(defmacro copy-region (region) (il:bquote (copy-list (il:\\\, region))))

(defmacro region-p (object) (il:bquote (il:regionp (il:\\\, object))))

(defmacro region-left (region) (il:bquote (il:|fetch| (il:region il:left) il:|of| (il:\\\, region))))

(defmacro region-right (region) (il:bquote (il:|fetch| (il:region il:right) il:|of| (il:\\\, region))))

(defmacro region-bottom (region) (il:bquote (il:|fetch| (il:region il:bottom) il:|of| (il:\\\, region))))

(defmacro region-top (region) (il:bquote (il:|fetch| (il:region il:top) il:|of| (il:\\\, region))))

(defmacro region-width (region) (il:bquote (il:|fetch| (il:region il:width) il:|of| (il:\\\, region))))

(defmacro region-height (region) (il:bquote (il:|fetch| (il:region il:height) il:|of| (il:\\\, region))))

(defmacro subregion-p (larger smaller) (il:bquote (il:subregionp (il:\\\, larger) (il:\\\, smaller))))

(defmacro intersect-regions (&rest regions) (il:bquote (il:intersectregions (il:\\\,@ regions))))

(defmacro inside-p (region position) (il:bquote (il:insidep (il:\\\, region) (il:\\\, position))))



(il:* il:|;;| "display streams")



(defmacro stream-clipping-region (stream) (il:bquote (il:dspclippingregion nil (il:\\\, stream))))

(defmacro stream-scale (stream) (il:bquote (il:dspscale nil (il:\\\, stream))))

(defmacro stream-x (stream) (il:bquote (il:dspxposition nil (il:\\\, stream))))

(defmacro stream-y (stream) (il:bquote (il:dspyposition nil (il:\\\, stream))))

(defmacro boole-to-op (value) (il:bquote (case (il:\\\, value) (:default nil) ((il:\\\, boole-1) (quote il:replace)) ((il:\\\, boole-ior) (quote il:paint)) ((il:\\\, boole-xor) (quote il:invert)) ((il:\\\, boole-andc1) (quote il:erase)) (otherwise (error "Unimplemented boole value")))))

(defun stream-bitblt (source destination &key (source-left 0) (source-bottom 0) (destination-left 0) (destination-bottom 0) width height (operation :default)) (macrolet ((boole-to-sourcetype (value) (il:bquote (case (il:\\\, value) ((il:\\\, (list boole-1 boole-ior boole-xor boole-andc1)) (quote il:input)) ((il:\\\, (list boole-c1 boole-and boole-eqv boole-orc1)) (quote il:invert)) (:default nil) (otherwise (error "Unimplemented boole value"))))) (boole-to-operation (value) (il:bquote (case (il:\\\, value) ((il:\\\, (list boole-1 boole-c1)) (quote il:replace)) ((il:\\\, (list boole-ior boole-orc1)) (quote il:paint)) ((il:\\\, (list boole-xor boole-eqv)) (quote il:invert)) ((il:\\\, (list boole-and boole-andc1)) (quote il:erase)) (:default nil) (otherwise (error "Unimplemented boole value")))))) (il:bitblt source source-left source-bottom destination destination-left destination-bottom width height (boole-to-sourcetype operation) (boole-to-operation operation))))

(defun stream-bltshade (texture destination &key (destination-left 0) (destination-bottom 0) width height (operation boole-1)) (il:bltshade texture destination destination-left destination-bottom width height (boole-to-op operation)))

(defun stream-draw-line (x1 y1 x2 y2 stream &key width (operation :default) color dashing) (il:drawline x1 y1 x2 y2 width (boole-to-op operation) stream color dashing))

(defun stream-draw-to (x y stream &key width (operation :default) color dashing) (il:drawto x y width (boole-to-op operation) stream color dashing))

(defmacro stream-move-to (x y stream) (il:bquote (il:moveto (il:\\\, x) (il:\\\, y) (il:\\\, stream))))

(defmacro stream-relative-move-to (dx dy stream) (il:bquote (il:relmoveto (il:\\\, dx) (il:\\\, dy) (il:\\\, stream))))

(defmacro stream-reset (stream) (il:bquote (il:dspreset (il:\\\, stream))))

(defmacro stream-string-region (string stream &key prin1-p readtable) (if (or prin1-p readtable) (il:bquote (il:stringregion (il:\\\, string) (il:\\\, stream) (il:\\\, prin1-p) (il:\\\, readtable))) (il:bquote (il:stringregion (il:\\\, string) (il:\\\, stream)))))

(defmacro stream-scroll (stream) (il:bquote (il:dspscroll nil (il:\\\, stream))))

(defun setf-stream-scroll (stream new-value) (il:dspscroll (and new-value (intern (string new-value) (find-package "INTERLISP"))) stream))

(defmacro stream-texture (stream) (il:bquote (il:dsptexture nil (il:\\\, stream))))

(defmacro stream-font (stream) (il:bquote (il:dspfont nil (il:\\\, stream))))

(defun stream-margin (stream margin) (ecase margin (:left (il:dspleftmargin nil stream)) (:right (il:dsprightmargin nil stream)) (:top (il:dsptopmargin nil stream)) (:bottom (il:dspbottommargin nil stream))))

(defun setf-stream-margin (stream margin new-value) (ecase margin (:left (il:dspleftmargin new-value stream)) (:right (il:dsprightmargin new-value stream)) (:top (il:dsptopmargin new-value stream)) (:bottom (il:dspbottommargin new-value stream))) new-value)

(defmacro stream-line-feed (stream) (il:bquote (il:dsplinefeed nil (il:\\\, stream))))

(defsetf stream-scroll setf-stream-scroll)

(defsetf stream-font (stream) (new-value) (il:bquote (progn (il:dspfont (il:\\\, new-value) (il:\\\, stream)) (il:\\\, new-value))))

(defsetf stream-margin setf-stream-margin)



(il:* il:|;;| "bitmaps  ")



(defun make-bitmap (width height) (il:bitmapcreate width height))

(defmacro bitmap-p (object) (il:bquote (il:bitmapp (il:\\\, object))))

(defmacro bitmap-width (bitmap) (il:bquote (il:bitmapwidth (il:\\\, bitmap))))

(defmacro bitmap-height (bitmap) (il:bquote (il:bitmapheight (il:\\\, bitmap))))



(il:* il:|;;| "windows   ")



(defsetf il:windowprop (window prop) (new-value) (il:bquote (progn (il:windowprop (il:\\\, window) (il:\\\, prop) (il:\\\, new-value)) (il:\\\, new-value))))

(defun make-window (&key region title border-size not-open-p) (il:createw region title border-size not-open-p))

(defmacro window-p (object) (il:bquote (il:windowp (il:\\\, object))))

(defmacro window-width (window) (il:bquote (il:windowprop (il:\\\, window) (quote il:width))))

(defmacro window-height (window) (il:bquote (il:windowprop (il:\\\, window) (quote il:height))))

(defmacro window-region (window) (il:bquote (il:windowprop (il:\\\, window) (quote il:region))))

(defmacro window-title (window) (il:bquote (il:windowprop (il:\\\, window) (quote il:title))))

(defmacro window-border (window) (il:bquote (il:windowprop (il:\\\, window) (quote il:border))))

(defmacro window-dsp (window) (il:bquote (il:windowprop (il:\\\, window) (quote il:dsp))))

(defmacro window-icon (window) (il:bquote (il:windowprop (il:\\\, window) (quote il:icon))))

(defun shrunken-window-p (window) (and (il:windowp window) (il:openwp (il:windowprop window (quote il:iconwindow)))))

(defun window-method-to-prop (method-name) (case method-name (:repaint (quote il:repaintfn)) (:reshape (quote il:reshapefn)) (:close (quote il:closefn)) (:button-event (quote il:buttoneventfn)) (:right-button-event (quote il:rightbuttonfn)) (:copy-button-event (quote il:copybuttoneventfn)) (:hardcopy (quote il:hardcopyfn)) (:shrink (quote il:iconfn)) (:expand (quote il:expandfn)) (:page-full (quote il:pagefullfn)) (otherwise method-name)))

(defmacro window-method (window method-name) (il:bquote (il:windowprop (il:\\\, window) (quote (il:\\\, (window-method-to-prop method-name))))))

(defmacro setf-window-method (window method-name new-value) (once-only (new-value) (il:bquote (progn (il:windowprop (il:\\\, window) (quote (il:\\\, (window-method-to-prop method-name))) (il:\\\, new-value)) (il:\\\, new-value)))))

(defmacro add-window-method (window method-name new-method &optional first-p) (il:bquote (il:windowaddprop (il:\\\, window) (quote (il:\\\, (window-method-to-prop method-name))) (il:\\\, new-method) (il:\\\,@ (if first-p (list t))))))

(defmacro delete-window-method (window method-name method) (il:bquote (il:windowdelprop (il:\\\, window) (quote (il:\\\, (window-method-to-prop method-name))) (il:\\\, method))))

(defsetf window-method setf-window-method)

(defmacro window-prop (window prop) (il:bquote (il:windowprop (il:\\\, window) (il:\\\, prop))))

(defmacro setf-window-prop (window prop new-value) (once-only (new-value) (il:bquote (progn (il:windowprop (il:\\\, window) (il:\\\, prop) (il:\\\, new-value)) (il:\\\, new-value)))))

(defmacro add-window-prop (window prop new-value) (il:bquote (il:windowaddprop (il:\\\, window) (il:\\\, prop) (il:\\\, new-value))))

(defmacro delete-window-prop (window prop value) (il:bquote (il:windowdelprop (il:\\\, window) (il:\\\, prop) (il:\\\, value))))

(defsetf window-prop setf-window-prop)

(defmacro open-window-p (window) (il:bquote (il:openwp (il:\\\, window))))

(defmacro open-window (window) (il:bquote (il:openw (il:\\\, window))))

(defmacro close-window (window) (il:bquote (il:closew (il:\\\, window))))

(defmacro to-top-window (window) (il:bquote (il:totopw (il:\\\, window))))

(defmacro clear-window (window) (il:bquote (il:clearw (il:\\\, window))))

(defmacro move-window (window &key position x y) (il:bquote (il:movew (il:\\\, window) (il:\\\,@ (if position (list position) (if (and x y) (list x y)))))))

(defmacro redisplay-window (window &optional region) (il:bquote (il:redisplayw (il:\\\, window) (il:\\\,@ (if region (list region))))))

(defmacro reshape-window (window &optional new-region) (il:bquote (il:shapew (il:\\\, window) (il:\\\,@ (if new-region (list new-region))))))

(defmacro invert-window (window &optional shade) (il:bquote (il:invertw (il:\\\, window) (il:\\\,@ (if shade (list shade))))))

(defmacro expand-window (window) (il:bquote (il:expandw (il:\\\, window))))



(il:* il:|;;| "metric properties")



(defmacro width-if-window (interior-width &optional border) (il:bquote (il:widthifwindow (il:\\\, interior-width) (il:\\\,@ (if border (list border))))))

(defmacro height-if-window (interior-height &optional title-p border) (il:bquote (il:heightifwindow (il:\\\, interior-height) (il:\\\,@ (if title-p (list title-p))) (il:\\\,@ (if border (list border))))))

(defmacro window-min-size (window) (il:bquote (il:windowprop (il:\\\, window) (quote il:minsize))))

(defmacro main-window-min-size (window) (il:bquote (il:windowprop (il:\\\, window) (quote il:mainwindowminsize))))

(defmacro window-max-size (window) (il:bquote (il:windowprop (il:\\\, window) (quote il:maxsize))))



(il:* il:|;;| "attached-windows")



(defmacro main-window (window) (il:bquote (il:mainwindow (il:\\\, window))))

(defmacro attached-windows (window) (il:bquote (il:attachedwindows (il:\\\, window))))

(defun attach-window (window-to-attach main-window edge &optional position-on-edge) (il:attachwindow window-to-attach main-window (intern (string edge) (find-package "INTERLISP")) (and position-on-edge (intern (string position-on-edge) (find-package "INTERLISP")))))

(defun attach-menu (menu mainwindow edge &optional position-on-edge) (il:attachmenu menu mainwindow (intern (string edge) (find-package "INTERLISP")) (and position-on-edge (intern (string position-on-edge) (find-package "INTERLISP")))))

(defmacro detach-window (window) (il:bquote (il:detachwindow (il:\\\, window))))

(defmacro detach-all-windows (window) (il:bquote (il:detachallwindows (il:\\\, window))))



(il:* il:|;;| "misc window fns")



(defmacro print-prompt (&rest exprs) (il:bquote (il:promptprint (il:\\\,@ exprs))))

(defmacro get-position (window) (il:bquote (il:getposition (il:\\\, window))))

(defmacro get-region (&optional min-width min-height initial-region) (il:bquote (il:getregion (il:\\\,@ (if (or min-width min-height) (list min-width min-height))) (il:\\\,@ (if initial-region (list initial-region))))))

(defmacro position-region (width height &optional window message) (il:bquote (il:getboxregion (il:\\\, width) (il:\\\, height) (il:\\\,@ (if (or window message) (list nil nil window message))))))



(il:* il:|;;| "cursor and mouse")



(defmacro window-cursor (window) (il:bquote (il:cursorposition nil (il:\\\, window))))

(defmacro mouse-state-p (button-form) (il:bquote (il:mousestate (il:\\\, (make-interlisp button-form)))))

(defmacro last-mouse-state-p (button-form) (il:bquote (il:lastmousestate (il:\\\, (make-interlisp button-form)))))

(defmacro until-mouse-state (button-form &optional millisecond-interval) (il:bquote (il:untilmousestate (il:\\\, (make-interlisp button-form)) (il:\\\,@ (if millisecond-interval (list millisecond-interval))))))

(defmacro get-mouse-state nil (il:bquote (il:getmousestate)))

(defmacro last-mouse-x (window) (il:bquote (il:lastmousex (il:\\\, window))))

(defmacro last-mouse-y (window) (il:bquote (il:lastmousey (il:\\\, window))))



(il:* il:|;;| "menus")



(defun normalize-subitems (item) (if (or (not (consp item)) (< (length item) 4)) item (xcl:destructuring-bind (label action prompt subitems) item (if (eq (car subitems) :subitems) (list label action prompt (cons (quote il:subitems) (mapcar (function normalize-subitems) (cdr subitems)))) item))))

(defun make-menu (&key items when-selected-fn (font il:menufont) title center-p (border-size 0) (outline-size (max 1 border-size)) track-cursor-p) (let ((items (mapcar (function normalize-subitems) items))) (xcl:record-create il:menu :items items :whenselectedfn when-selected-fn :menufont font :title title :centerflg center-p :menubordersize border-size :menuoutlinesize outline-size :changeoffsetflg track-cursor-p)))

(defmacro menu-p (object) (il:bquote (typep (il:\\\, object) (quote il:menu))))

(defun copy-menu (menu &key (new-items (xcl:record-fetch il:menu il:items menu)) (new-selected-fn (xcl:record-fetch il:menu il:whenselectedfn menu)) (new-font (xcl:record-fetch il:menu il:menufont menu)) (new-title (xcl:record-fetch il:menu il:title menu))) (xcl:record-create il:menu :items (mapcar (function normalize-subitems) new-items) :whenselectedfn new-selected-fn :menufont new-font :title new-title :centerflg (xcl:record-fetch il:menu il:centerflg menu) :menubordersize (xcl:record-fetch il:menu il:menubordersize menu) :menuoutlinesize (xcl:record-fetch il:menu il:menuoutlinesize menu) :changeoffsetflg (xcl:record-fetch il:menu il:changeoffsetflg menu)))

(defmacro menu-items (menu) (il:bquote (xcl:record-fetch il:menu il:items (il:\\\, menu))))

(defmacro menu-when-selected-fn (menu) (il:bquote (xcl:record-fetch il:menu il:whenselectedfn (il:\\\, menu))))

(defmacro pop-up-menu (menu) (il:bquote (il:menu (il:\\\, menu))))

(defmacro window-from-menu (menu) (il:bquote (il:wfrommenu (il:\\\, menu))))

(defmacro menu-prop (menu prop) (il:bquote (il:getmenuprop (il:\\\, menu) (il:\\\, prop))))

(defmacro setf-menu-prop (menu prop new-value) (once-only (new-value) (il:bquote (progn (il:putmenuprop (il:\\\, menu) (il:\\\, prop) (il:\\\, new-value)) (il:\\\, new-value)))))

(defsetf menu-prop setf-menu-prop)



(il:* il:|;;| "fonts and display metrics")



(defun make-interlisp (object) (and object (typecase object (cons (cons (make-interlisp (car object)) (make-interlisp (cdr object)))) (symbol (intern (string object) (find-package "INTERLISP"))) (otherwise object))))

(defun make-keyword (object) (and object (etypecase object (cons (cons (make-keyword (car object)) (make-keyword (cdr object)))) (symbol (intern (string object) (find-package "KEYWORD"))))))

(defun make-font (&key family size face rotation device) (il:fontcreate (make-interlisp family) size (make-interlisp face) rotation (make-interlisp device)))

(defun coerce-font (font stream) (if (eq (il:fontprop font (quote il:device)) (il:imagestreamtype stream)) font (il:fontcreate (il:fontprop font (quote il:family)) (il:fontprop font (quote il:size)) (il:fontprop font (quote il:face)) (il:fontprop font (quote il:rotation)) stream)))

(defmacro font-p (object) (il:bquote (il:fontp (il:\\\, object))))

(defun font-family (font) (make-keyword (il:fontprop font (quote il:family))))

(defmacro font-size (font) (il:bquote (il:fontprop (il:\\\, font) (quote il:size))))

(defun font-face (font) (make-keyword (il:fontprop font (quote il:face))))

(defmacro font-ascent (font) (il:bquote (il:fontprop (il:\\\, font) (quote il:ascent))))

(defmacro font-descent (font) (il:bquote (il:fontprop (il:\\\, font) (quote il:descent))))

(defmacro font-height (font) (il:bquote (il:fontprop (il:\\\, font) (quote il:height))))

(defun default-font (device) (il:defaultfont (make-interlisp device)))

(defmacro char-code-width (char-code font) (il:bquote (il:charwidth (il:\\\, char-code) (il:\\\, font))))

(defmacro char-width (char font) (il:bquote (il:charwidth (char-code (il:\\\, char)) (il:\\\, font))))

(defmacro string-width (string font &key prin1-p readtable) (if (or prin1-p readtable) (il:bquote (il:stringwidth (il:\\\, string) (il:\\\, font) (il:\\\, prin1-p) (il:\\\,@ (if readtable (list readtable))))) (il:bquote (il:stringwidth (il:\\\, string) (il:\\\, font)))))

(defmacro string-region (string window &key prin1-p readtable) (if (or prin1-p readtable) (il:bquote (il:stringregion (il:\\\, string) (il:\\\, window) (il:\\\, prin1-p) (il:\\\,@ (if readtable (list readtable))))) (il:bquote (il:stringregion (il:\\\, string) (il:\\\, window)))))



(il:* il:|;;| "Common variables")



(defvar *black-shade* il:blackshade)

(defvar *white-shade* il:whiteshade)

(defvar *gray-shade* il:grayshade)

(xcl:define-file-environment "TWOD-GRAPHICS" :package "TDG" :compiler :compile-file :readtable "XCL")
(il:putprops il:twod-graphics il:copyright ("Xerox Corporation" 1988))
(il:declare\: il:dontcopy
  (il:filemap (nil)))
il:stop