(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