(FILECREATED "18-Mar-86 16:55:13" {ERIS}<LISPCORE>LIBRARY>ICONW.;12 20687
changes to: (FNS TEXTICON)
(VARS ICONWCOMS DEFAULTTEXTICON)
previous date: "11-Sep-85 11:00:04" {ERIS}<LISPCORE>LIBRARY>ICONW.;9)
(* Copyright (c) 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT ICONWCOMS)
(RPAQQ ICONWCOMS ((FNS ICONW ICONW.SHADE \ICONW.REPAINTFN)
(FNS TITLEDICONW ICONW.TITLE \ICONW.SHOW.TITLE \ICONW.FORMAT.TITLE
\ICONW.FORMAT.TITLE1 ICONTITLE)
(COMS (* for use as DEFAULTICONFN)
(FNS TEXTICON)
(INITVARS (DEFAULTTEXTICON)))
(RECORDS TITLEDICON)
(INITVARS (DEFAULTICONWIDTH 100)
(DEFAULTICONFONT (FONTCREATE (QUOTE HELVETICA)
10)))
(DECLARE: DONTCOPY (RECORDS ICONTITLE)
(GLOBALVARS DEFAULTICONWIDTH DEFAULTICONFONT DEFAULTTEXTICON WBorder))))
(DEFINEQ
(ICONW
[LAMBDA (ICON MASK POSITION NOOPENFLG) (* bvm: "26-Aug-85 16:01")
(* 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.)
[COND
((NOT (type? POSITION POSITION))
(SETQ POSITION (GETBOXPOSITION (fetch (BITMAP BITMAPWIDTH) of ICON)
(fetch (BITMAP BITMAPHEIGHT) of ICON]
(LET ((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 AFTERMOVEFN)
(FUNCTION \ICONW.REPAINTFN))
(WINDOWPROP ICONW (QUOTE TOTOPFN)
(FUNCTION \ICONW.REPAINTFN))
(WINDOWPROP ICONW (QUOTE OPENFN)
(FUNCTION \ICONW.REPAINTFN))
(OR NOOPENFLG (OPENW ICONW))
ICONW])
(ICONW.SHADE
[LAMBDA (WINDOW SHADE) (* bvm: "30-Aug-85 17:26")
(LET (SHADEBM ERASEBM IMAGEBM)
[COND
(SHADE (COND
[(NEQ SHADE WHITESHADE) (* Build an auxiliary bitmap that is shaded the
requested shade in all the parts where the image shows)
[OR (SETQ SHADEBM (WINDOWPROP WINDOW (QUOTE SHADEIMAGE)))
(WINDOWPROP WINDOW (QUOTE SHADEIMAGE)
(SETQ SHADEBM (BITMAPCREATE [fetch (BITMAP BITMAPWIDTH)
of (SETQ IMAGEBM
(WINDOWPROP WINDOW
(QUOTE
ICONIMAGE]
(fetch (BITMAP BITMAPHEIGHT)
of IMAGEBM]
(BLTSHADE SHADE SHADEBM 0 0 NIL NIL (QUOTE REPLACE))
(COND
((SETQ ERASEBM (WINDOWPROP WINDOW (QUOTE ICONMASK)))
(BITBLT ERASEBM 0 0 SHADEBM 0 0 NIL NIL (QUOTE INVERT)
(QUOTE ERASE]
(T (WINDOWPROP WINDOW (QUOTE SHADEIMAGE)
NIL]
(PROG1 (WINDOWPROP WINDOW (QUOTE ICONSHADE)
SHADE)
(AND SHADE (OPENWP WINDOW)
(\ICONW.REPAINTFN WINDOW])
(\ICONW.REPAINTFN
[LAMBDA (WINDOW) (* bvm: "31-Jul-85 14:05")
(PROG ((IMAGEBM (WINDOWPROP WINDOW (QUOTE ICONIMAGE)))
(ERASEBM (WINDOWPROP WINDOW (QUOTE ICONMASK)))
(SHADEBM (WINDOWPROP WINDOW (QUOTE SHADEIMAGE)))
WIDTH HEIGHT)
(SETQ WIDTH (fetch (BITMAP BITMAPWIDTH) of IMAGEBM))
(SETQ HEIGHT (fetch (BITMAP BITMAPHEIGHT) of IMAGEBM))
(TOTOPW WINDOW T) (* Bring the window to the top without calling its
TOTOPFN (i.e., this very fn))
[COND
(ERASEBM (* There's clipping to do, so copy the background,
erase bits where the image lies, then OR in the image)
(BITBLT (WINDOWPROP WINDOW (QUOTE IMAGECOVERED))
0 0 WINDOW 0 0 WIDTH HEIGHT (QUOTE INPUT)
(QUOTE REPLACE))
(BITBLT ERASEBM 0 0 WINDOW 0 0 WIDTH HEIGHT (QUOTE INPUT)
(QUOTE ERASE))
(BITBLT IMAGEBM 0 0 WINDOW 0 0 WIDTH HEIGHT (QUOTE INPUT)
(QUOTE PAINT)))
(T (* No clipping, just copy out the original image)
(BITBLT IMAGEBM 0 0 WINDOW 0 0 WIDTH HEIGHT (QUOTE INPUT)
(QUOTE REPLACE]
(COND
(SHADEBM (* The image is to be shaded)
(BITBLT SHADEBM 0 0 WINDOW 0 0 WIDTH HEIGHT (QUOTE INPUT)
(QUOTE PAINT])
)
(DEFINEQ
(TITLEDICONW
[LAMBDA (ICON TITLE FONT POSITION NOOPENFLG JUST BREAKCHARS OPERATION)
(* bvm: "11-Sep-85 10:58")
(* Given a TITLEDICON, create an instance of it with
specific text.)
(LET (BITS ICONW TITLESPEC REG MASK FORMATTED)
[COND
[(NOT BREAKCHARS)
(SETQ BREAKCHARS (CHARCODE (SPACE]
[(EQ BREAKCHARS (QUOTE FILE)) (* File name field separators)
(SETQ BREAKCHARS (CHARCODE (SPACE - } : > %. ; /]
((NLISTP BREAKCHARS)
(SETQ BREAKCHARS (LIST BREAKCHARS]
(SETQ FONT (FONTCREATE (OR FONT DEFAULTICONFONT)))
(SELECTQ OPERATION
((REPLACE INVERT))
(ERASE (SETQQ OPERATION INVERT))
((NIL PAINT)
(SETQQ OPERATION REPLACE))
(\ILLEGAL.ARG OPERATION))
[COND
(ICON (SETQ BITS (BITMAPCOPY (fetch (TITLEDICON ICON) of ICON)))
(SETQ REG (fetch TITLEREG of ICON))
(SETQ MASK (fetch (TITLEDICON MASK) of ICON)))
(T (LET ((TITLEWIDTH (STRINGWIDTH TITLE FONT))
(BORDER WBorder)
WIDTH HEIGHT) (* Make a simple rectangle with a border like a window)
(SETQ FORMATTED (\ICONW.FORMAT.TITLE TITLE FONT (IMAX DEFAULTICONWIDTH
(LRSH TITLEWIDTH 1))
BREAKCHARS))
(* Try actually formatting the title, expecting about
three lines, to see what dimensions the window needs to
be)
(SETQ WIDTH (WIDTHIFWINDOW (OR (CDR (for X in FORMATTED largest (CDR X)))
DEFAULTICONWIDTH)
BORDER))
(SETQ HEIGHT (HEIGHTIFWINDOW (TIMES (LENGTH FORMATTED)
(FONTPROP FONT (QUOTE HEIGHT)))
NIL BORDER))
(SETQ BITS (BITMAPCREATE WIDTH HEIGHT))
(BLTSHADE BLACKSHADE BITS 0 0 WIDTH HEIGHT (QUOTE REPLACE))
(* Fill with black, then white out everything but the
border)
[COND
((NEQ OPERATION (QUOTE INVERT))
(BLTSHADE WHITESHADE BITS (FOLDHI BORDER 2)
(FOLDHI BORDER 2)
(IDIFFERENCE WIDTH BORDER)
(IDIFFERENCE HEIGHT BORDER)
(QUOTE REPLACE]
(SETQ REG (CREATEREGION BORDER BORDER (IDIFFERENCE WIDTH (LLSH BORDER 1))
(IDIFFERENCE HEIGHT (LLSH BORDER 1]
(SETQ ICONW (ICONW BITS MASK POSITION T))
(WINDOWPROP ICONW (QUOTE ICONTITLESPEC)
(SETQ TITLESPEC
(create ICONTITLE
ICIMAGE ← BITS
ICFONT ← FONT
ICJUST ← JUST
ICREGION ← REG
ICBREAKCHARS ← BREAKCHARS
ICOPERATION ← OPERATION)))
(\ICONW.SHOW.TITLE ICONW TITLESPEC (MKSTRING (OR TITLE " "))
T) (* 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.)
ICONW])
(ICONW.TITLE
[LAMBDA (ICONW TITLE) (* bvm: "30-Aug-85 17:19")
(* * Returns current title of icon, sets new title if TITLE not NIL)
(LET [(TITLESPEC (WINDOWPROP ICONW (QUOTE ICONTITLESPEC]
(COND
((NOT TITLESPEC)
(ERROR "Not a titled icon" ICONW))
(T (PROG1 (fetch ICTITLE of TITLESPEC)
(COND
(TITLE (\ICONW.SHOW.TITLE ICONW TITLESPEC TITLE)
(AND (OPENWP ICONW)
(\ICONW.REPAINTFN ICONW])
(\ICONW.SHOW.TITLE
[LAMBDA (ICONW TITLESPEC TEXT NEWFLG) (* bvm: " 1-Sep-85 21:15")
(LET ((JUST (fetch ICJUST of TITLESPEC))
(FONT (fetch ICFONT of TITLESPEC))
(REG (fetch ICREGION of TITLESPEC))
(BITS (BITMAPCOPY (fetch ICIMAGE of TITLESPEC)))
(OPERATION (fetch ICOPERATION of TITLESPEC))
(MASK (WINDOWPROP ICONW (QUOTE ICONMASK)))
DS LMARG MAXHEIGHT MAXWIDTH MAXLINES WIDTH FORMATTEDLINES FONTHEIGHT TITLEHEIGHT)
(SETQ DS (DSPCREATE BITS)) (* Set up a displaystream so we can print onto the
icon's image bitmap)
(DSPCLIPPINGREGION REG DS)
(DSPXOFFSET 0 DS)
(DSPYOFFSET 0 DS)
(DSPFONT FONT DS) (* Set the right font)
(DSPOPERATION OPERATION DS) (* Don't erase any bits from the icon image--paint the
msg)
(LINELENGTH 32000 DS) (* Avoid trouble with PRIN1)
(DSPLEFTMARGIN (SETQ LMARG (fetch (REGION LEFT) of REG))
DS) (* Left margin for the message)
(DSPRIGHTMARGIN 32700 DS)
(COND
((NOT NEWFLG) (* Clear anything in the title region)
(DSPFILL REG (SELECTQ OPERATION
(INVERT BLACKSHADE)
WHITESHADE)
(QUOTE REPLACE)
DS)))
(SETQ FONTHEIGHT (FONTPROP FONT (QUOTE HEIGHT))) (* Single line's height)
(SETQ MAXHEIGHT (fetch (REGION HEIGHT) of REG)) (* Max height of the title)
(SETQ MAXWIDTH (fetch (REGION WIDTH) of REG))
[SETQ FORMATTEDLINES (\ICONW.FORMAT.TITLE TEXT FONT MAXWIDTH (fetch ICBREAKCHARS
of TITLESPEC)
(SETQ MAXLINES (IQUOTIENT MAXHEIGHT FONTHEIGHT]
(SETQ TITLEHEIGHT (ITIMES FONTHEIGHT (FLENGTH FORMATTEDLINES)))
(* Height of the message)
(MOVETO LMARG [IPLUS (fetch (REGION BOTTOM) of REG)
(IDIFFERENCE [IMIN MAXHEIGHT (COND
((EQMEMB (QUOTE TOP)
JUST)
(* Top-flush title)
(fetch (REGION TOP) of REG))
((EQMEMB (QUOTE BOTTOM)
JUST)
(* Bottom-flush title)
(IPLUS (fetch (REGION BOTTOM) of REG)
TITLEHEIGHT))
((IGREATERP TITLEHEIGHT MAXHEIGHT)
MAXHEIGHT)
(T (* Centered vertically title)
(IDIFFERENCE MAXHEIGHT (LRSH (IDIFFERENCE
MAXHEIGHT
TITLEHEIGHT)
1]
(FONTPROP FONT (QUOTE ASCENT]
DS) (* Move to the left end of the first message line)
(bind (NCH ← 0) to MAXLINES as LINE in FORMATTEDLINES
do (* FORMATTEDLINES is a list of elements
(lastch# . width))
[COND
((NOT (EQMEMB (QUOTE LEFT)
JUST)) (* Move to this line's left end)
(LET [(LEFTOVER (IDIFFERENCE MAXWIDTH (CDR LINE]
(RELMOVETO (COND
((EQMEMB (QUOTE RIGHT)
JUST)
LEFTOVER)
(T (LRSH LEFTOVER 1)))
0 DS]
(bind (MAXCHAR ←(CAR LINE))
CH
do (* Print the characters -- except the final SPACE on a
line, or a CR)
(SETQ CH (NTHCHARCODE TEXT (add NCH 1)))
(COND
([NOT (AND (EQ NCH (CAR LINE))
(FMEMB CH (CHARCODE (CR SPACE]
(\OUTCHAR DS CH)))
repeatuntil (EQ NCH MAXCHAR))
(TERPRI DS))
[COND
(MASK (BITBLT MASK 0 0 BITS 0 0 (fetch BITMAPWIDTH of BITS)
(fetch BITMAPHEIGHT of BITS)
(QUOTE INVERT)
(QUOTE ERASE]
(replace ICTITLE of TITLESPEC with TEXT)
(WINDOWPROP ICONW (QUOTE ICONIMAGE)
BITS)
ICONW])
(\ICONW.FORMAT.TITLE
[LAMBDA (TITLE FONT MAXWIDTH BREAKCHARS MAXLINES) (* bvm: "27-Aug-85 18:21")
(LET ((RESULT (\ICONW.FORMAT.TITLE1 TITLE FONT MAXWIDTH BREAKCHARS)))
(COND
((OR (NULL MAXLINES)
(GEQ MAXLINES (LENGTH RESULT))) (* It fit, so return it)
RESULT)
(T (* Try breaking less)
(LET ((WASTED 0)
(EXCESS 0))
[for I from 1 as LINE in RESULT do (COND
[(LEQ I MAXLINES)
(add WASTED (IDIFFERENCE MAXWIDTH
(CDR LINE]
(T (add EXCESS (CDR LINE]
(COND
([AND (LESSP EXCESS WASTED)
(GEQ MAXLINES (LENGTH (SETQ RESULT (\ICONW.FORMAT.TITLE1
TITLE FONT MAXWIDTH BREAKCHARS
(IDIFFERENCE MAXWIDTH (IQUOTIENT (IDIFFERENCE
WASTED EXCESS)
MAXLINES]
(* Reformatted okay by forcing less wastage per line)
RESULT)
(T (* Take out all the breaks)
(\ICONW.FORMAT.TITLE1 TITLE FONT MAXWIDTH NIL MAXWIDTH])
(\ICONW.FORMAT.TITLE1
[LAMBDA (TITLE FONT MAXWIDTH BREAKCHARS MINWIDTH) (* bvm: "11-Sep-85 10:52")
(LET* ((TITLELEN (NCHARS TITLE))
(DONE (EQ TITLELEN 0))
(FONTHEIGHT (FONTPROP FONT (QUOTE HEIGHT)))
(NCH 0)
(WIDTHSOFAR 0)
TCH CHWIDTH)
(until DONE
collect (* Gather the icon title, broken into lines which fit.)
(bind CH LASTBREAKPOS LASTBREAKWIDTH
do (* Run thru the characters one by one.)
(COND
((IGEQ NCH TITLELEN) (* That was the last character.)
(SETQ DONE T)
(RETURN (CONS TITLELEN WIDTHSOFAR)))
(T (* Look at the next character.)
(SETQ CH (NTHCHARCODE TITLE (add NCH 1)))
[COND
((EQ CH (CHARCODE CR)) (* CR forces a new line.)
(RETURN (PROG1 (CONS NCH WIDTHSOFAR)
(SETQ WIDTHSOFAR 0]
[COND
((IGREATERP (add WIDTHSOFAR (SETQ CHWIDTH (CHARWIDTH CH FONT)))
MAXWIDTH) (* We're past the right margin.
Time to stop.)
(RETURN (COND
((AND (EQ CH (CHARCODE SPACE))
(FMEMB CH BREAKCHARS))
(* We just happened to end at a space, so it's safe to
break here)
(PROG1 (CONS NCH (IDIFFERENCE WIDTHSOFAR CHWIDTH))
(SETQ WIDTHSOFAR 0)))
[LASTBREAKPOS
(* There is a space we can break the line at.
Break there.)
(SETQ WIDTHSOFAR (IDIFFERENCE WIDTHSOFAR
LASTBREAKWIDTH))
(CONS LASTBREAKPOS
(COND
((EQ (NTHCHARCODE TITLE
LASTBREAKPOS)
(CHARCODE SPACE))
(IDIFFERENCE
LASTBREAKWIDTH
(CHARWIDTH (CHARCODE SPACE)
FONT)))
(T LASTBREAKWIDTH]
(T (* There were no spaces on this line.
Break after the last character that did fit.)
(CONS (SUB1 NCH)
(IDIFFERENCE WIDTHSOFAR (SETQ WIDTHSOFAR
CHWIDTH]
(COND
((AND (FMEMB CH BREAKCHARS)
(OR (NULL MINWIDTH)
(IGEQ WIDTHSOFAR MINWIDTH)))
(* Remember where spaces are, so we can back up and split lines there if possible. Don't split if there isn't enough
on the line yet)
(SETQ LASTBREAKPOS NCH)
(SETQ LASTBREAKWIDTH WIDTHSOFAR])
(ICONTITLE
[LAMBDA (MSG REG FONT ICONW JUST) (* bvm: "16-Aug-85 20:20")
(* Obsolete entry)
(LET [(TITLESPEC (WINDOWPROP ICONW (QUOTE ICONTITLESPEC]
(COND
((NOT TITLESPEC)
(ERROR "Not a titled icon" ICONW))
(T (COND
(REG (replace ICREGION of TITLESPEC with REG)))
(COND
(FONT (replace ICFONT of TITLESPEC with FONT)))
(COND
(JUST (replace ICJUST of TITLESPEC with JUST)))
(\ICONW.SHOW.TITLE ICONW TITLESPEC MSG])
)
(* for use as DEFAULTICONFN)
(DEFINEQ
(TEXTICON
[LAMBDA (WINDOW TEXT) (* bvm:
"18-Mar-86 16:54")
(OR (WINDOWP TEXT)
(LET*[[ICON (TITLEDICONW DEFAULTTEXTICON [COND
(TEXT)
((AND (SETQ TEXT (WINDOWPROP WINDOW (QUOTE TITLE)
))
(NEQ (NCHARS TEXT)
0))
TEXT)
(T (CONCAT "Icon made " (DATE]
NIL
(WINDOWPROP WINDOW (QUOTE ICONPOSITION]
(REG (WINDOWPROP ICON (QUOTE REGION]
(WINDOWPROP WINDOW (QUOTE ICONPOSITION)
(create POSITION
XCOORD ←(fetch (REGION LEFT) of REG)
YCOORD ←(fetch (REGION BOTTOM) of REG))) (* Remember position for
the next shrinkage)
ICON])
)
(RPAQ? DEFAULTTEXTICON )
[DECLARE: EVAL@COMPILE
(RECORD TITLEDICON (ICON MASK TITLEREG))
]
(RPAQ? DEFAULTICONWIDTH 100)
(RPAQ? DEFAULTICONFONT (FONTCREATE (QUOTE HELVETICA)
10))
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(RECORD ICONTITLE (ICIMAGE ICTITLE ICFONT ICJUST ICREGION ICBREAKCHARS ICOPERATION))
]
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS DEFAULTICONWIDTH DEFAULTICONFONT DEFAULTTEXTICON WBorder)
)
)
(PUTPROPS ICONW COPYRIGHT ("Xerox Corporation" 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1077 5320 (ICONW 1087 . 2469) (ICONW.SHADE 2471 . 3703) (\ICONW.REPAINTFN 3705 . 5318))
(5321 18746 (TITLEDICONW 5331 . 8882) (ICONW.TITLE 8884 . 9448) (\ICONW.SHOW.TITLE 9450 . 13997) (
\ICONW.FORMAT.TITLE 13999 . 15277) (\ICONW.FORMAT.TITLE1 15279 . 18105) (ICONTITLE 18107 . 18744)) (
18784 20126 (TEXTICON 18794 . 20124)))))
STOP