(FILECREATED " 5-Dec-83 15:19:58" {PHYLUM}<LISP>SOURCES>COLORPATCH.;3 10613
changes to: (VARS COLORPATCHCOMS)
previous date: "14-NOV-83 11:46:43" {PHYLUM}<LISP>SOURCES>COLORPATCH.;2)
(* Copyright (c) 1983 by Xerox Corporation)
(PRETTYCOMPRINT COLORPATCHCOMS)
(RPAQQ COLORPATCHCOMS ((FNS \SLOWBLTCHAR PRINTBITMAP READBITMAP)
(FNS \DSPFONT.DISPLAY \COERCEFONTDESC)))
(DEFINEQ
(\SLOWBLTCHAR
[LAMBDA (CHARCODE DISPLAYSTREAM) (* rrb "17-OCT-83 13:49")
(* case of BLTCHAR where either font is rotated or
destination is a color bitmap.
DISPLAYSTREAM is known to be a display stream.)
(PROG (ROTATION (DD (fetch IMAGEDATA of DISPLAYSTREAM)))
(SETQ ROTATION (fetch (FONTDESCRIPTOR ROTATION) of (fetch DDFONT of DD)))
(RETURN
(COND
[(EQ 0 ROTATION)
(PROG (NEWX LEFT RIGHT (CURX (ffetch DDXPOSITION of DD)))
[COND
((IGREATERP (SETQ NEWX (IPLUS CURX (\DSPGETCHARWIDTH CHARCODE DD)))
(ffetch DDRightMargin of DD))
(* past RIGHT margin, force eol)
(\DSPPRINTCR/LF (CHARCODE EOL)
DISPLAYSTREAM)
(SETQ CURX (ffetch DDXPOSITION of DD))
(SETQ NEWX (IPLUS CURX (\DSPGETCHARWIDTH CHARCODE DD]
(* update the x position.)
(freplace DDXPOSITION of DD with NEWX)
(SETQ CURX (\DSPTRANSFORMX CURX DD))
(SETQ LEFT (IMAX (ffetch DDClippingLeft of DD)
CURX))
(SETQ RIGHT (IMIN (ffetch DDClippingRight of DD)
(\DSPTRANSFORMX NEWX DD)))
(RETURN (COND
((AND (ILESSP LEFT RIGHT)
(NEQ (fetch PBTHEIGHT of (SETQ NEWX (ffetch DDPILOTBBT
of DD)))
0))
(SELECTQ (fetch (BITMAP BITMAPBITSPERPIXEL)
of (ffetch (\DISPLAYDATA DDDestination) of DD))
(1 (.WHILE.TOP.DS. DISPLAYSTREAM
(freplace PBTDESTBIT of NEWX
with LEFT)
(freplace PBTWIDTH of NEWX
with (IDIFFERENCE RIGHT LEFT))
(freplace PBTSOURCEBIT of NEWX
with (IDIFFERENCE
(IPLUS (\DSPGETCHAROFFSET
CHARCODE DD)
LEFT)
CURX))
(\PILOTBITBLT NEWX 0)))
(4 (OR (\DDHASFONT DD)
(\DDSETCOLORFONT DISPLAYSTREAM))
(.WHILE.TOP.DS.
DISPLAYSTREAM
(freplace PBTDESTBIT of NEWX
with (SETQ LEFT (LLSH LEFT 2)))
(freplace PBTWIDTH of NEWX
with (IDIFFERENCE (LLSH RIGHT 2)
LEFT))
(freplace PBTSOURCEBIT of NEWX
with (IDIFFERENCE (IPLUS (LLSH (\DSPGETCHAROFFSET
CHARCODE DD)
2)
LEFT)
(LLSH CURX 2)))
(\PILOTBITBLT NEWX 0)))
(8 (OR (\DDHASFONT DD)
(\DDSETCOLORFONT DISPLAYSTREAM))
(.WHILE.TOP.DS.
DISPLAYSTREAM
(freplace PBTDESTBIT of NEWX
with (SETQ LEFT (LLSH LEFT 3)))
(freplace PBTWIDTH of NEWX
with (IDIFFERENCE (LLSH RIGHT 3)
LEFT))
(freplace PBTSOURCEBIT of NEWX
with (IDIFFERENCE (IPLUS (LLSH (\DSPGETCHAROFFSET
CHARCODE DD)
3)
LEFT)
(LLSH CURX 3)))
(\PILOTBITBLT NEWX 0)))
(SHOULDNT))
T]
(T (* handle rotated fonts)
(PROG ((YPOS (ffetch DDYPOSITION of DD))
(HEIGHTMOVED (\DSPGETCHARWIDTH CHARCODE DD))
(FONT (ffetch DDFONT of DD)))
(RETURN (COND
((EQ ROTATION 90) (* don't force CR for rotated fonts.)
(\DSPYPOSITION.DISPLAY (IPLUS YPOS HEIGHTMOVED)
DISPLAYSTREAM)
(* update the display stream x position.)
(BITBLT (fetch (FONTDESCRIPTOR CHARACTERBITMAP) of FONT)
0
(\DSPGETCHAROFFSET CHARCODE DD)
DISPLAYSTREAM
(ADD1 (IDIFFERENCE (ffetch DDXPOSITION of DD)
(FONTASCENT FONT)))
YPOS
(FONTHEIGHT FONT)
HEIGHTMOVED))
((EQ ROTATION 270)
(\DSPYPOSITION.DISPLAY (IDIFFERENCE YPOS HEIGHTMOVED)
DISPLAYSTREAM)
(BITBLT (fetch (FONTDESCRIPTOR CHARACTERBITMAP) of FONT)
0
(\DSPGETCHAROFFSET CHARCODE DD)
DISPLAYSTREAM
(IDIFFERENCE (ffetch DDXPOSITION of DD)
(FONTDESCENT FONT))
(ffetch DDYPOSITION of DISPLAYSTREAM)
(FONTHEIGHT FONT)
HEIGHTMOVED))
(T (ERROR "Not implemented to rotate by other than 0, 90 or 270"])
(PRINTBITMAP
[LAMBDA (BITMAP FILE) (* rrb "14-NOV-83 11:45")
(* Writes a bitmap on A file such that READBITMAP will
read it back in.)
(DECLARE (LOCALVARS . T))
(PROG ((BM BITMAP))
(COND
((type? BITMAP BITMAP))
([AND (LITATOM BITMAP)
(type? BITMAP (SETQ BM (EVALV BITMAP] (* Coerce litatoms for compatibility with original
specification)
)
(T (printout T "******** " BITMAP " is not a BITMAP." T)
(RETURN NIL)))
(printout FILE "(" .P2 (BITMAPWIDTH BM)
, .P2 (BITMAPHEIGHT BM)) (* if the number of bits per pixel is not 1, write it
out.)
(COND
((NEQ (BITSPERPIXEL BM)
1)
(SPACES 1 FILE)
(PRIN2 (BITSPERPIXEL BM)
FILE))) (* Enclose in list so that compile-copying works)
(* now write out contents.)
(\WRITEBITMAP BM FILE)
(PRIN1 ")" FILE])
(READBITMAP
[LAMBDA (FILE) (* rrb "10-NOV-83 15:11")
(* reads the a bitmap from the input file.)
(SKIPSEPRS FILE)
(OR (EQ (READC FILE)
(QUOTE %())
(ERROR "BAD FORMAT OF BITMAP IN FILE"))
(PROG [BASE BM W BITSPERPIXEL (WIDTH (RATOM FILE))
(HEIGHT (RATOM FILE))
(STRM (GETSTREAM FILE (QUOTE INPUT]
[SETQ BITSPERPIXEL (COND
((EQ (SKIPSEPRS STRM)
(QUOTE %"))
1)
(T (* after height can come the bits per pixel.)
(RATOM FILE]
(SETQ W (FOLDHI (ITIMES BITSPERPIXEL WIDTH)
BITSPERWORD))
(SETQ BM (BITMAPCREATE WIDTH HEIGHT BITSPERPIXEL))
(SETQ BASE (fetch BITMAPBASE of BM))
(COND
((OR (EQ WIDTH 0)
(EQ HEIGHT 0)))
[(EQ (SKIPSEPRS STRM)
(QUOTE %"))
(FRPTQ HEIGHT (SKIPSEPRS STRM)
(OR (EQ (\BIN STRM)
(CHARCODE %"))
(GO BAD))
(FRPTQ W [\PUTBASEBYTE BASE 0 (LOGOR (LLSH (IDIFFERENCE (\BIN STRM)
(SUB1 (CHARCODE A)))
4)
(IDIFFERENCE (\BIN STRM)
(SUB1 (CHARCODE A]
[\PUTBASEBYTE BASE 1 (LOGOR (LLSH (IDIFFERENCE (\BIN STRM)
(SUB1 (CHARCODE A)))
4)
(IDIFFERENCE (\BIN STRM)
(SUB1 (CHARCODE A]
(SETQ BASE (\ADDBASE BASE 1)))
(OR (EQ (\BIN STRM)
(CHARCODE %"))
(GO BAD]
(T (GO BAD)))
(SKIPSEPRS STRM)
(OR (EQ (\BIN STRM)
(CHARCODE %)))
(GO BAD))
(RETURN BM)
BAD (ERROR "BAD FORMAT OF BITMAP IN FILE"])
)
(DEFINEQ
(\DSPFONT.DISPLAY
[LAMBDA (DISPLAYSTREAM FONT) (* rrb " 5-Dec-83 12:57")
(* sets the font that a display stream uses to print
characters. DISPLAYSTREAM is guaranteed to be a stream
of type display)
(PROG (XFONT OLDFONT NBITS (DD (fetch IMAGEDATA of DISPLAYSTREAM)))
(* save old value to return, smash new value and update
the bitchar portion of the record.)
(RETURN (PROG1 (SETQ OLDFONT (fetch DDFONT of DD))
(COND
(FONT (SETQ XFONT (OR (\GETFONTDESC FONT (QUOTE DISPLAY)
T)
(FONTCOPY (ffetch DDFONT of DD)
FONT)))
(* updating font information is fairly expensive
operation. Don't bother unless font has changed.)
[COND
((NEQ (SETQ NBITS (ffetch (BITMAP BITMAPBITSPERPIXEL)
of (ffetch (\DISPLAYDATA DDDestination)
of DD)))
1) (* color case, create a font with the current foreground
and background colors.)
(SETQ XFONT (\GETCOLORFONT XFONT (DSPCOLOR NIL DISPLAYSTREAM)
(DSPBACKCOLOR NIL DISPLAYSTREAM)
NBITS]
(OR (EQ XFONT OLDFONT)
(UNINTERRUPTABLY
(freplace DDFONT of DD with XFONT)
(freplace DDLINEFEED of DD
with (IMINUS (fetch \SFHeight of XFONT)))
(\SFFixFont DISPLAYSTREAM DD))])
(\COERCEFONTDESC
[LAMBDA (SPEC DEVICE NOERRORFLG) (* rrb " 5-Dec-83 15:02")
(* Coerces SPEC to a fontdescriptor)
(PROG [(FONT (COND
((type? FONTDESCRIPTOR SPEC)
SPEC)
[(NULL SPEC)
(DEFAULTFONT (OR DEVICE (QUOTE DISPLAY]
((OR (IMAGESTREAMP SPEC)
(type? WINDOW SPEC))
(DSPFONT NIL SPEC))
(T
(* If called with NOERRORFLG=T (e.g. from DSPFONT) we want to suppress invalid arg errors as well as font not
found, so we can move on to other possible coercions.)
(FONTCREATE SPEC NIL NIL NIL DEVICE NOERRORFLG]
(RETURN (COND
(FONT (* if there was no font found, return NIL.)
(COND
((AND DEVICE (NEQ DEVICE (fetch FONTDEVICE of FONT)))
(FONTCOPY FONT (QUOTE DEVICE)
DEVICE
(QUOTE NOERROR)
NOERRORFLG))
(T FONT])
)
(PUTPROPS COLORPATCH COPYRIGHT ("Xerox Corporation" 1983))
(DECLARE: DONTCOPY
(FILEMAP (NIL (403 7828 (\SLOWBLTCHAR 413 . 4959) (PRINTBITMAP 4961 . 6138) (READBITMAP 6140 . 7826))
(7829 10532 (\DSPFONT.DISPLAY 7839 . 9530) (\COERCEFONTDESC 9532 . 10530)))))
STOP