(FILECREATED " 2-MAR-83 12:51:40" {PHYLUM}<LISPUSERS>BITMAPFNS.;9
 8677   

      changes to:  (FNS READCUFONTFILE)
		   (VARS BITMAPFNSCOMS)

      previous date: " 4-JAN-83 00:28:58" {PHYLUM}<LISPUSERS>BITMAPFNS.;7)


(* Copyright (c) 1983 by Xerox Corporation)

(PRETTYCOMPRINT BITMAPFNSCOMS)

(RPAQQ BITMAPFNSCOMS
 ((FNS READBINARYBITMAP WRITEBINARYBITMAP WRITEBM WRITEBMLST READBMLST READBM 
			   READPRESS READCUFONTFILE)
		      (MACROS RPCHK WORDIN WORDOUT)
		      (FNS FADEMOVIE FADETO WINDOWBM)))
(DEFINEQ

(READBINARYBITMAP

  [LAMBDA (WIDTH HEIGHT FILE)      (* lmm " 4-JAN-83 00:19")

                                   (* reads a bitmap from the output file.)

    (PROG ((BM (BITMAPCREATE WIDTH HEIGHT)))
          (\BINS (GETSTREAM FILE (QUOTE INPUT))
		 (fetch
 BITMAPBASE of
 BM)
		 0
		 (ITIMES (fetch
 BITMAPRASTERWIDTH of
 BM)
			 (fetch
 BITMAPHEIGHT of
 BM)
			 2))
          (RETURN BM])

(WRITEBINARYBITMAP

  [LAMBDA (BITMAP)                 (* lmm " 4-JAN-83 00:11")

    (\BOUTS FILE [ffetch
 BITMAPBASE of
 (SETQ BITMAP (\DTEST BITMAP (QUOTE BITMAP]
	    0
	    (ITIMES (ffetch
 BITMAPHEIGHT of
 BITMAP)
		    (ffetch
 BITMAPRASTERWIDTH of
 BITMAP)
		    BYTESPERWORD])

(WRITEBM

  [LAMBDA (FILE BITMAP)            (* lmm " 4-JAN-83 00:11")

    [WORDOUT FILE (ffetch
 BITMAPWIDTH of
 (SETQ BITMAP (\DTEST BITMAP (QUOTE BITMAP]
    (WORDOUT FILE (ffetch
 BITMAPHEIGHT of
 BITMAP))
    (WRITEBINARYBITMAP
 BITMAP])

(WRITEBMLST

  [LAMBDA (FILE LST)                                         (* bas: "24-APR-82 15:03")

    (PROG [(F (\GETOFD (OPENFILE FILE (QUOTE OUTPUT]
          (for
 I in
 LST do
 (WRITEBM
 F I))
          (CLOSEF F])

(READBMLST

  [LAMBDA (FILE)                                             (* bas: " 4-JUN-82 15:21")

    (bind
 [F ←(\GETOFD (OPENFILE FILE (QUOTE INPUT] until
 (EOFP F) collect
 (READBM
 F)
       finally
 (CLOSEF F])

(READBM

  [LAMBDA (FILE)                   (* lmm " 4-JAN-83 00:21")

    (READBINARYBITMAP
 (WORDIN FILE)
		      (WORDIN FILE)
		      FILE])

(READPRESS

  [LAMBDA (FILENAME)               (* lmm " 4-JAN-83 00:25")

    (RESETLST (PROG (WW HT MICAWIDTH MICAHEIGHT BITMAP TOTCOUNT (OFD (GETOFD (OPENFILE FILENAME
										       (QUOTE INPUT)
										       (QUOTE OLD))
									     (QUOTE INPUT)))
			X WIDTH)
		    (RESETSAVE NIL (LIST (QUOTE CLOSEF)
					 OFD))
		    (RPCHK 256)    (* Edotcode)

		    (SETQ WW (IQUOTIENT (WORDIN OFD)
					16))
                                   (* Width)

		    (SETQ HT (WORDIN OFD))
                                   (* Height)

		    (until
 (SELECTC (SETQ X (WORDIN OFD))
				    ((IPLUS 512 3)
                                   (* Edotmode and 3)

				      (RPCHK 2)
                                   (* Edotsize)

				      (SETQ MICAWIDTH (WORDIN OFD))
				      (SETQ MICAHEIGHT (WORDIN OFD))
				      NIL)
				    (1 
                                   (* Edotwindow)

				       (RPCHK 0)
				       (SETQ WIDTH (WORDIN OFD))
				       (RPCHK 0)
				       (RPCHK HT)
				       NIL)
				    (3 T)
				    (HELP)))
		    [\BINS OFD (fetch
 BITMAPBASE of
 (SETQ BITMAP (BITMAPCREATE (ITIMES WW 16)
									       HT)))
			   0
			   (ITIMES 2 (SETQ TOTCOUNT (ITIMES HT WW]
		    (RPCHK 0)      (* Entity list terminator)

		    [COND
		      (NIL         (* more checks, not necessary)

			   (PROGN (RPCHK (IPLUS 65280 238))
                                   (* Nop, setx)

				  (RPCHK 0)
				  (RPCHK (IPLUS 65280 239))
                                   (* Nop, sety)

				  (RPCHK 0)
				  (RPCHK (IPLUS 65280 252))
                                   (* Nop, show dots)

				  (RPCHK 0]
		    (RETURN BITMAP])

(READCUFONTFILE

  [LAMBDA (FILE FAMILY SIZE FACE)                            (* lmm " 2-MAR-83 12:51")

    (PROG (FD NUMBCODES RW BITMAP OFFSETS HEIGHT WW H WIDTHS FONTDESC CSN CHAR WID BUFFER CN
	      (OFD (OPENSTREAM FILE (QUOTE INPUT)
			       (QUOTE OLD)))
	      FDENTRY
	      (MAXCHAR 256                                   (* maximum character code)
))
          (SETQ H (WORDIN OFD))
          (SETQ WW (WORDIN OFD))
          (SETQ BUFFER (BITMAPCREATE (ITIMES WW 16)
				     H))
          (while
 (NOT (EOFP OFD))
	     do
 (SETQ CHAR (WORDIN OFD))
		(SETQ WID (WORDIN OFD))
		(SETQ CN (LRSH CHAR 8))
		(SETQ CHAR (LOGAND CHAR 255))
		[COND
		  [(NOT (SETQ FDENTRY (ASSOC CN FD)))
		    (SETQ FONTDESC
		      (create
 FONTDESCRIPTOR
			      FONTFAMILY ← FAMILY
			      FONTSIZE ← SIZE
			      FONTFACE ← FACE
			      FONTDEVICE ←(QUOTE DISPLAY)))
		    (replace
 CHARACTERBITMAP of
 FONTDESC with
 (BITMAPCREATE (ITIMES (ITIMES WW 
										      MAXCSNCODES)
										    16)
									    H))
		    (replace
 \SFDescent of
 FONTDESC with
 (IDIFFERENCE H SIZE))
		    (replace
 \SFAscent of
 FONTDESC with
 H)
		    (replace
 \SFHeight of
 FONTDESC with
 (IDIFFERENCE (fetch
 \SFAscent of
 FONTDESC)
								     (fetch
 \SFDescent of
 FONTDESC)))
		    (replace
 FIRSTCHAR of
 FONTDESC with
 0)
		    (replace
 LASTCHAR of
 FONTDESC with
 MAXCHAR)
		    (replace
 \SFOffsets of
 FONTDESC with
 (ARRAY (IPLUS 2 MAXCHAR)
								(QUOTE SMALLPOSP)
								0 0))
		    (replace
 \SFWidths of
 FONTDESC with
 (ARRAY (IPLUS 2 MAXCHAR)
							       (QUOTE SMALLPOSP)
							       0 0))
		    (push
 FD (SETQ FDENTRY (LIST CN FONTDESC 0]
		  (T (SETQ FONTDESC (CADR FDENTRY]
		(SETA (fetch
 \SFOffsets of
 FONTDESC)
		      CHAR
		      (CADDR FDENTRY))
		(SETA (fetch
 \SFWidths of
 FONTDESC)
		      CHAR WID)
		(\BINS OFD (fetch
 BITMAPBASE of
 BUFFER)
		       0
		       (LLSH (ITIMES WW H)
			     1))
		(BITBLT BUFFER 0 0 (fetch
 CHARACTERBITMAP of
 FONTDESC)
			(CADDR FDENTRY)
			0 WID H NIL (QUOTE REPLACE))
		(add
 (CADDR FDENTRY)
		     WID))
          (RETURN (PROG1 FD (CLOSEF OFD])
)
(DECLARE: EVAL@COMPILE 

(PUTPROPS RPCHK MACRO
 ((N)
		       (OR (EQ (WORDIN OFD)
			       N)
			   (HELP))))

(PUTPROPS WORDIN MACRO
 ((STREAM)
			(IPLUS (LLSH (BIN STREAM)
				     8)
			       (BIN STREAM))))

(PUTPROPS WORDOUT MACRO
 ((F W)
			 (BOUT F (LRSH W 8))
			 (BOUT F (LOGAND W 255))))
)
(DEFINEQ

(FADEMOVIE

  [LAMBDA (BITMAPLST WIN NTIMES WAIT)                        (* rrb "29-MAY-82 16:37")

                                                             (* shows a list of bitmaps in a window.)

    (PROG (FRAMEPTR [FRAMES (for
 X in
 BITMAPLST collect
 (COND
							  ((OR (BITMAPP X)
							       (FIXP X))
							    X)
							  ((BITMAPP (EVALV X))
							    (EVALV X))
							  (T (ERROR X " movie frame is not a bitmap."]
		    (WAIT (OR (FIXP WAIT)
			      250))
		    (NTIMES (OR (FIXP NTIMES)
				1)))
          (OR (SETQ FRAMEPTR FRAMES)
	      (RETURN))
          [COND
	    ((TYPENAMEP WIN (QUOTE WINDOW)))
	    (T (SETQ WIN (WINDOWBM
 (CAR FRAMEPTR]
      NEXT(FADETO
 WIN (CAR FRAMEPTR)
		  0)
          (DISMISS (COND
		     [(FIXP (CADR FRAMEPTR))                 (* if entry is a number, it is dismiss time.)

		       (CAR (SETQ FRAMEPTR (CDR FRAMEPTR]
		     (T WAIT)))
          (COND
	    ((SETQ FRAMEPTR (CDR FRAMEPTR))
	      (GO NEXT))
	    ((IGREATERP (SETQ NTIMES (SUB1 NTIMES))
			0)                                   (* do another round.)

	      (SETQ FRAMEPTR FRAMES)
	      (GO NEXT))
	    (T (RETURN])

(FADETO

  [LAMBDA (TO
 FROM
 WAIT)                                     (* rrb "29-MAY-82 16:36")

    (to
 16 as
 I from
 1 by
 I do
 (BITBLT NIL NIL NIL TO NIL NIL NIL NIL (QUOTE TEXTURE)
				       (QUOTE ERASE)
				       I)
			       (BITBLT FROM NIL NIL TO NIL NIL NIL NIL (QUOTE MERGE)
				       (QUOTE PAINT)
				       I)
			       (DISMISS (OR WAIT 250])

(WINDOWBM

  [LAMBDA (BM POS)                                           (* rrb "29-MAY-82 20:50")

    (PROG ((W (WIDTHIFWINDOW (fetch
 BITMAPWIDTH of
 BM)
			     2))
	   (H (HEIGHTIFWINDOW (fetch
 BITMAPHEIGHT of
 BM)
			      NIL 2))
	   WIN)
          (BITBLT BM NIL NIL (SETQ WIN (CREATEW (create
 REGION
							WIDTH ← W
							HEIGHT ← H
							LEFT ←[fetch
 XCOORD
								 of
 (COND
								      ((POSITIONP POS)
									POS)
								      (T (SETQ POS (GETBOXPOSITION
									     W H]
							BOTTOM ←(fetch
 YCOORD of
 POS))
						NIL 2)))
          (RETURN WIN])
)
(PUTPROPS BITMAPFNS COPYRIGHT ("Xerox Corporation" 1983))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (515 6092 (READBINARYBITMAP 525 . 946) (WRITEBINARYBITMAP 948 . 1257) (WRITEBM 1259 . 
1523) (WRITEBMLST 1525 . 1765) (READBMLST 1767 . 2006) (READBM 2008 . 2161) (READPRESS 2163 . 3843) (
READCUFONTFILE 3845 . 6090)) (6405 8597 (FADEMOVIE 6415 . 7589) (FADETO 7591 . 7983) (WINDOWBM 7985 . 
8595)))))
STOP