(FILECREATED "27-Jan-85 19:14:33" {ERIS}<LISPCORE>LIBRARY>ICONW.;6 18938
changes to: (FNS ICONW.REPAINTFN ICONW.SHADE ICONW.MOVEFN)
(VARS ICONWCOMS)
previous date: "28-Nov-84 15:20:56" {ERIS}<LISPCORE>LIBRARY>ICONW.;4)
(* Copyright (c) 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT ICONWCOMS)
(RPAQQ ICONWCOMS ((FNS ICONTITLE ICONW ICONW.FORMATLINE ICONW.MOVEFN ICONW.REPAINTFN ICONW.SHADE
ICONW.TOTOPWFN TITLEDICONW)
(RECORDS TITLEDICON)))
(DEFINEQ
(ICONTITLE
[LAMBDA (MSG REG FONT ICONW JUST) (* jds "28-Nov-84 15:19")
(* Put the text MSG into the ICONW within the bounds of
REG)
(PROG ((MASK (WINDOWPROP ICONW (QUOTE ICONMASK)))
BITS DS MAXHEIGHT TITLETOP WIDTH NLINES TMSG FONTHEIGHT LEFTMAR TITLEHEIGHT)
[COND
((SETQ BITS (WINDOWPROP ICONW (QUOTE ICONORIGINALIMAGE)))
(* There is an original image that we're writing over.
Copy it, and smash the old icon image)
(SETQ BITS (BITMAPCOPY BITS))
(WINDOWPROP ICONW (QUOTE ICONIMAGE)
BITS))
(T (* No pre-existing image; w're creating the original.
Save a copy of the blank image.)
(SETQ BITS (WINDOWPROP ICONW (QUOTE ICONIMAGE)))
(WINDOWPROP ICONW (QUOTE ICONORIGINALIMAGE)
(BITMAPCOPY BITS]
[COND
(REG (* Setting up the original image region)
(WINDOWPROP ICONW (QUOTE ICONREGION)
REG))
(T (* Redisplaying; get the ORIGINAL region)
(SETQ REG (WINDOWPROP ICONW (QUOTE ICONREGION]
[COND
(FONT (* Setting the original icon font)
(WINDOWPROP ICONW (QUOTE ICONFONT)
FONT))
(T (* Redisplaying; retrieve the font.)
(SETQ FONT (WINDOWPROP ICONW (QUOTE ICONFONT]
[COND
(JUST (* Setting the original icon's justification)
(WINDOWPROP ICONW (QUOTE ICONJUST)
JUST))
(T (* Redisplaying; retrieve the justification info)
(SETQ JUST (WINDOWPROP ICONW (QUOTE ICONJUST]
(SETQ DS (DSPCREATE BITS)) (* Set up a displaystream so we can print onto the
icon's image bitmap)
(DSPCLIPPINGREGION (create REGION
LEFT ← 0
BOTTOM ← 0
WIDTH ←(BITMAPWIDTH BITS)
HEIGHT ←(fetch BITMAPHEIGHT of BITS))
DS)
(DSPXOFFSET 0 DS)
(DSPYOFFSET 0 DS)
(SETQ FONT (OR FONT (FONTCREATE (QUOTE HELVETICA)
10))) (* The font to put the msg in)
(SETQ FONTHEIGHT (FONTPROP FONT (QUOTE HEIGHT))) (* Single line's height)
[SETQ NLINES (bind (NCH ← 1)
TCH repeatuntil (IGREATERP NCH (NCHARS MSG))
collect (* Gather the icon title, broken into lines which fit.)
(PROG1 (SETQ TCH (ICONW.FORMATLINE (SUBSTRING MSG NCH)
(fetch WIDTH of REG)
FONT))
(add NCH (IABS (CAR TCH]
(SETQ MAXHEIGHT (fetch HEIGHT of REG)) (* Max height of the title)
(SETQ TITLEHEIGHT (ITIMES FONTHEIGHT (FLENGTH NLINES)))
(* Height of the message)
[SETQ TITLETOP (IMIN MAXHEIGHT (COND
((OR (EQ JUST (QUOTE TOP))
(MEMB (QUOTE TOP)
JUST)) (* Top-flush title)
(fetch TOP of REG))
((OR (EQ JUST (QUOTE BOTTOM))
(MEMB (QUOTE BOTTOM)
JUST)) (* Bottom-flush title)
(IPLUS (fetch BOTTOM of REG)
TITLEHEIGHT))
((IGREATERP TITLEHEIGHT MAXHEIGHT)
MAXHEIGHT)
(T (* Centered vertically title)
(IDIFFERENCE (fetch TOP of REG)
(LRSH (IDIFFERENCE MAXHEIGHT TITLEHEIGHT)
1]
(DSPFONT FONT DS) (* Set the right font)
(DSPOPERATION (QUOTE PAINT)
DS) (* Don't erase any bits from the icon image--paint the
msg)
(LINELENGTH 1000 DS) (* Avoid trouble with PRIN1)
(DSPLEFTMARGIN (fetch LEFT of REG)
DS) (* Left margin for the message)
(DSPRIGHTMARGIN 32700 DS)
(MOVETO (fetch LEFT of REG)
(IDIFFERENCE TITLETOP (FONTPROP FONT (QUOTE ASCENT)))
DS) (* Move to the left end of the first message line)
(bind (MESS ←(OPENSTRINGSTREAM (MKSTRING MSG))) for N in NLINES as HT from 0 to MAXHEIGHT
by FONTHEIGHT
do [SETQ LEFTMAR (COND
((OR (EQ JUST (QUOTE LEFT))
(MEMB (QUOTE LEFT)
JUST))
0)
((OR (EQ JUST (QUOTE RIGHT))
(MEMB (QUOTE RIGHT)
JUST))
(IABS (CDR N)))
(T (LRSH (IABS (CDR N))
1] (* Decide where this line should start)
(RELMOVETO LEFTMAR 0 DS) (* Move to this line's left end)
(bind CH for I from 1 to (IABS (CAR N))
do (* Print the characters -- except the final SPACE on a
line, or a CR)
(SETQ CH (BIN MESS))
(OR (AND (IEQP I (IABS (CAR N)))
(EQ CH (CHARCODE % )))
(BOUT DS CH)))
(COND
((ILESSP 0 (CAR N)) (* This line ended in CR--go to a new line NOW)
(TERPRI DS)))
finally (CLOSEF? MESS))
(BITBLT MASK 0 0 BITS 0 0 (fetch BITMAPWIDTH of BITS)
(fetch BITMAPHEIGHT of BITS)
(QUOTE INVERT)
(QUOTE ERASE))
(RETURN ICONW])
(ICONW
[LAMBDA (ICON MASK POSITION NOOPENFLG) (* edited: "14-MAR-83 14:00")
(* creates a window that merges with its background. This is done by putting the background in the original bits,
erasing the bits that are on in MASK and then painting the bits from IMAGEBM.)
(PROG (ICONW)
[SETQ POSITION (COND
((type? POSITION POSITION)
POSITION)
((REGIONP POSITION))
(T (GETBOXPOSITION (fetch (BITMAP BITMAPWIDTH) of ICON)
(fetch (BITMAP BITMAPHEIGHT) of ICON]
(SETQ ICONW (CREATEW (create REGION
LEFT ←(fetch (POSITION XCOORD) of POSITION)
BOTTOM ←(fetch (POSITION YCOORD) of POSITION)
WIDTH ←(fetch (BITMAP BITMAPWIDTH) of ICON)
HEIGHT ←(fetch (BITMAP BITMAPHEIGHT) of ICON))
NIL 0 T))
(WINDOWPROP ICONW (QUOTE RESHAPEFN)
(QUOTE DON'T))
(WINDOWPROP ICONW (QUOTE ICONIMAGE)
ICON)
(WINDOWPROP ICONW (QUOTE ICONMASK)
MASK)
(WINDOWPROP ICONW (QUOTE MOVEFN)
(QUOTE ICONW.MOVEFN))
(WINDOWPROP ICONW (QUOTE OPENFN)
(QUOTE ICONW.REPAINTFN))
(OR NOOPENFLG (OPENW ICONW))
(RETURN ICONW])
(ICONW.FORMATLINE
[LAMBDA (MSG WIDTH FONT) (* jds " 1-Aug-84 11:26")
(* Returns a list of the char# relative to char 1 of where to break next line, and how much space was left over
(for centering &c))
(COND
[MSG (* If there really is a title, go ahead and format the
next line.)
(bind (TX ← 0)
(LASTB ← 0)
(CH ← 0)
(TMSG ←(OPENSTRINGSTREAM MSG))
(MSGLEN ←(NCHARS MSG)) for I from 1 by 1
do (* Run thru the characters one by one.)
(COND
[(IGREATERP TX WIDTH) (* We're past the right margin.
Time to stop.)
(CLOSEF? TMSG)
(RETURN (COND
((LISTP LASTB) (* There is a space we can break the line at.
Break there.)
LASTB)
(T (* There were no spaces on this line.
Break after the last character that did fit.)
(CONS (IDIFFERENCE I 2)
(IDIFFERENCE WIDTH (IDIFFERENCE TX (CHARWIDTH CH FONT]
[(EOFP TMSG) (* That was the last character.)
(CLOSEF? TMSG)
(RETURN (CONS (SUB1 I)
(IDIFFERENCE WIDTH TX]
(T (* Look at the next character.)
(SETQ CH (BIN TMSG))
(SELCHARQ CH
[SPACE (* Remember where spaces are, so we can back up and
split lines there if possible.)
(SETQ LASTB (CONS I (IDIFFERENCE WIDTH TX]
[CR (* CR forces a new line.)
(RETURN (CONS (IMINUS I)
(IDIFFERENCE WIDTH TX]
NIL)
(SETQ TX (IPLUS TX (CHARWIDTH CH FONT]
(T (* There isn't a title; return a dummy entry for the
line formatter.)
(CONS 0 WIDTH])
(ICONW.MOVEFN
(LAMBDA (WINDOW NEW.POSITION) (* ejs: "27-Jan-85 18:02")
(* moves an overpaint window)
(PROG (IMAGEBM ERASEBM REGION SAVEBM NOWOPEN? ICONSHADE SHADEBM)
(SETQ IMAGEBM (WINDOWPROP WINDOW (QUOTE ICONIMAGE)))
(SETQ ERASEBM (WINDOWPROP WINDOW (QUOTE ICONMASK)))
(SETQ REGION (WINDOWPROP WINDOW (QUOTE REGION)))
(SETQ SAVEBM (WINDOWPROP WINDOW (QUOTE IMAGECOVERED)))
(* close the window in case its new position intersects
its old position. \CLOSEW1 closes the window without
calling the closefn.)
(COND
((ACTIVEWP WINDOW)
(SETQ NOWOPEN? T) (* copy the bits from the new screen position into the
image.)
(\CLOSEW1 WINDOW)))
(BITBLT (SCREENBITMAP)
(fetch (POSITION XCOORD) of NEW.POSITION)
(fetch (POSITION YCOORD) of NEW.POSITION)
SAVEBM 0 0 (fetch (REGION WIDTH) of REGION)
(fetch (REGION HEIGHT) of REGION)
(QUOTE INPUT)
(QUOTE REPLACE))
(BITBLT ERASEBM 0 0 SAVEBM 0 0 (fetch (BITMAP BITMAPWIDTH) of ERASEBM)
(fetch (BITMAP BITMAPHEIGHT) of ERASEBM)
(QUOTE INPUT)
(QUOTE ERASE))
(COND
((SETQ ICONSHADE (WINDOWPROP WINDOW (QUOTE ICONSHADE)))
(OR (SETQ SHADEBM (WINDOWPROP WINDOW (QUOTE SHADEIMAGE)))
(WINDOWPROP WINDOW (QUOTE SHADEIMAGE)
(SETQ SHADEBM (BITMAPCOPY ERASEBM))))
(BITBLT NIL NIL NIL SHADEBM 0 0 NIL NIL (QUOTE TEXTURE)
(QUOTE REPLACE)
ICONSHADE)
(BITBLT ERASEBM 0 0 SHADEBM 0 0 NIL NIL (QUOTE INVERT)
(QUOTE ERASE))
(BITBLT SHADEBM 0 0 SAVEBM 0 0 (fetch (BITMAP BITMAPWIDTH) of SHADEBM)
(fetch (BITMAP BITMAPHEIGHT) of SHADEBM)
(QUOTE SOURCE)
(QUOTE PAINT))))
(BITBLT IMAGEBM 0 0 SAVEBM 0 0 (fetch (BITMAP BITMAPWIDTH) of IMAGEBM)
(fetch (BITMAP BITMAPHEIGHT) of IMAGEBM)
(QUOTE INPUT)
(QUOTE PAINT)) (* open the window without calling the openfn.)
(AND NOWOPEN? (\OPENW1 WINDOW))
(RETURN))))
(ICONW.REPAINTFN
(LAMBDA (WINDOW) (* ejs: "27-Jan-85 19:13")
(PROG (IMAGEBM ERASEBM REGION SHADE SHADEBM)
(SETQ IMAGEBM (WINDOWPROP WINDOW (QUOTE ICONIMAGE)))
(SETQ ERASEBM (WINDOWPROP WINDOW (QUOTE ICONMASK)))
(SETQ REGION (WINDOWPROP WINDOW (QUOTE REGION)))
(BITBLT (WINDOWPROP WINDOW (QUOTE IMAGECOVERED))
0 0 WINDOW 0 0 (fetch (REGION WIDTH) of REGION)
(fetch (REGION HEIGHT) of REGION)
(QUOTE SOURCE)
(QUOTE REPLACE))
(BITBLT ERASEBM 0 0 WINDOW 0 0 (fetch (BITMAP BITMAPWIDTH) of ERASEBM)
(fetch (BITMAP BITMAPHEIGHT) of ERASEBM)
(QUOTE SOURCE)
(QUOTE ERASE))
(COND
((SETQ SHADE (WINDOWPROP WINDOW (QUOTE ICONSHADE)))
(OR (SETQ SHADEBM (WINDOWPROP WINDOW (QUOTE SHADEIMAGE)))
(WINDOWPROP WINDOW (QUOTE SHADEIMAGE)
(SETQ SHADEBM (BITMAPCOPY ERASEBM))))
(BITBLT NIL NIL NIL SHADEBM 0 0 NIL NIL (QUOTE TEXTURE)
(QUOTE REPLACE)
SHADE)
(BITBLT ERASEBM 0 0 SHADEBM 0 0 NIL NIL (QUOTE INVERT)
(QUOTE ERASE))
(BITBLT SHADEBM 0 0 WINDOW 0 0 (fetch (BITMAP BITMAPWIDTH) of SHADEBM)
(fetch (BITMAP BITMAPHEIGHT) of SHADEBM)
(QUOTE SOURCE)
(QUOTE PAINT))))
(BITBLT IMAGEBM 0 0 WINDOW 0 0 (fetch (BITMAP BITMAPWIDTH) of IMAGEBM)
(fetch (BITMAP BITMAPHEIGHT) of IMAGEBM)
(QUOTE SOURCE)
(QUOTE PAINT))
(RETURN))))
(ICONW.SHADE
(LAMBDA (WINDOW SHADE) (* ejs: "27-Jan-85 19:10")
(PROG (IMAGEBM ERASEBM REGION SHADEBM)
(SETQ IMAGEBM (WINDOWPROP WINDOW (QUOTE ICONIMAGE)))
(SETQ ERASEBM (WINDOWPROP WINDOW (QUOTE ICONMASK)))
(SETQ REGION (WINDOWPROP WINDOW (QUOTE REGION)))
(SETQ SHADEBM (WINDOWPROP WINDOW (QUOTE SHADEIMAGE)))
(OR SHADEBM (WINDOWPROP WINDOW (QUOTE SHADEIMAGE)
(SETQ SHADEBM (BITMAPCOPY ERASEBM))))
(BITBLT (WINDOWPROP WINDOW (QUOTE IMAGECOVERED))
0 0 WINDOW 0 0 (fetch (REGION WIDTH) of REGION)
(fetch (REGION HEIGHT) of REGION)
(QUOTE SOURCE)
(QUOTE REPLACE))
(BITBLT ERASEBM 0 0 WINDOW 0 0 (fetch (BITMAP BITMAPWIDTH) of ERASEBM)
(fetch (BITMAP BITMAPHEIGHT) of ERASEBM)
(QUOTE SOURCE)
(QUOTE ERASE))
(COND
(SHADE (BITBLT NIL NIL NIL SHADEBM 0 0 NIL NIL (QUOTE TEXTURE)
(QUOTE REPLACE)
SHADE)
(BITBLT ERASEBM 0 0 SHADEBM 0 0 NIL NIL (QUOTE INVERT)
(QUOTE ERASE))
(BITBLT SHADEBM 0 0 WINDOW 0 0 (fetch (BITMAP BITMAPWIDTH) of SHADEBM)
(fetch (BITMAP BITMAPHEIGHT) of SHADEBM)
(QUOTE SOURCE)
(QUOTE PAINT))))
(BITBLT IMAGEBM 0 0 WINDOW 0 0 (fetch (BITMAP BITMAPWIDTH) of IMAGEBM)
(fetch (BITMAP BITMAPHEIGHT) of IMAGEBM)
(QUOTE SOURCE)
(QUOTE PAINT))
(WINDOWPROP WINDOW (QUOTE ICONSHADE)
SHADE)
(RETURN))))
(ICONW.TOTOPWFN
[LAMBDA (WINDOW NEW.POSITION) (* jds "17-MAR-83 15:18")
(* moves an overpaint window)
(PROG (IMAGEBM ERASEBM REGION SAVEBM NOWOPEN?)
(SETQ IMAGEBM (WINDOWPROP WINDOW (QUOTE ICONIMAGE)))
(SETQ ERASEBM (WINDOWPROP WINDOW (QUOTE ICONMASK)))
(SETQ REGION (WINDOWPROP WINDOW (QUOTE REGION)))
(SETQ SAVEBM (WINDOWPROP WINDOW (QUOTE IMAGECOVERED)))
(* close the window in case its new position intersects
its old position. \CLOSEW1 closes the window without
calling the closefn.)
(COND
((ACTIVEWP WINDOW)
(SETQ NOWOPEN? T) (* copy the bits from the new screen position into the
image.)
(\CLOSEW1 WINDOW)))
(BITBLT (SCREENBITMAP)
(fetch (POSITION XCOORD) of NEW.POSITION)
(fetch (POSITION YCOORD) of NEW.POSITION)
SAVEBM 0 0 (fetch (REGION WIDTH) of REGION)
(fetch (REGION HEIGHT) of REGION)
(QUOTE INPUT)
(QUOTE REPLACE))
(BITBLT ERASEBM 0 0 SAVEBM 0 0 (fetch (BITMAP BITMAPWIDTH) of ERASEBM)
(fetch (BITMAP BITMAPHEIGHT) of ERASEBM)
(QUOTE INPUT)
(QUOTE ERASE))
(BITBLT IMAGEBM 0 0 SAVEBM 0 0 (fetch (BITMAP BITMAPWIDTH) of IMAGEBM)
(fetch (BITMAP BITMAPHEIGHT) of IMAGEBM)
(QUOTE INPUT)
(QUOTE PAINT)) (* open the window without calling the openfn.)
(AND NOWOPEN? (\OPENW1 WINDOW))
(RETURN])
(TITLEDICONW
[LAMBDA (ICON MSG FONT POS NOOPENFLG JUST) (* jds "21-May-84 09:55")
(* Given a TITLEDICON, create an instance of it with
specific text.)
(PROG ((BITS (BITMAPCOPY (fetch (TITLEDICON ICON) of ICON)))
ICONW)
(SETQ MSG (OR MSG " "))
(SETQ ICONW (ICONTITLE MSG (fetch TITLEREG of ICON)
FONT
(ICONW BITS (fetch (TITLEDICON MASK) of ICON)
POS T)
JUST)) (* Create a copy of the icon image, with the text
imposed on it.)
(* Save it for restoration on open, repaint, &c)
(OR NOOPENFLG (OPENW ICONW)) (* Open the window, unless he wants it kept closed.)
(RETURN ICONW])
)
[DECLARE: EVAL@COMPILE
(RECORD TITLEDICON (ICON MASK TITLEREG))
]
(PUTPROPS ICONW COPYRIGHT ("Xerox Corporation" 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (516 18785 (ICONTITLE 526 . 6802) (ICONW 6804 . 8113) (ICONW.FORMATLINE 8115 . 10161) (
ICONW.MOVEFN 10163 . 12728) (ICONW.REPAINTFN 12730 . 14439) (ICONW.SHADE 14441 . 16144) (
ICONW.TOTOPWFN 16146 . 17868) (TITLEDICONW 17870 . 18783)))))
STOP