(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)


(FILECREATED "24-Sep-2023 13:54:45" {WMEDLEY}<lispusers>bitmapfns.;2
 5976   

      :EDIT-BY rmk

      :CHANGES-TO (FNS READPRESS)

      :PREVIOUS-DATE " 3-Jun-86 14:13:59" {WMEDLEY}<lispusers>bitmapfns.;1)


(* ; "
Copyright (c) 1983-1986 by Xerox Corporation.
")

(PRETTYCOMPRINT BITMAPFNSCOMS)

(RPAQQ BITMAPFNSCOMS
 ((FNS READBINARYBITMAP WRITEBINARYBITMAP WRITEBM WRITEBMLST READBMLST READBM 
                           READPRESS WINDOWBM)
                      (DECLARE%: DONTCOPY (MACROS RPCHK))))
(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 'INPUT)
                 (fetch
 BITMAPBASE of
 BM)
                 0
                 (ITIMES (fetch
 BITMAPRASTERWIDTH of
 BM)
                        (fetch
 BITMAPHEIGHT of
 BM)
                        2))
          (RETURN BM])

(WRITEBINARYBITMAP

  [LAMBDA (BITMAP FILE)                                      (* JWogulis "26-Dec-84 15:06")

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

(WRITEBM

  [LAMBDA (FILE BITMAP)                                      (* lmm " 6-Jun-85 16:46")

    [BOUT16 FILE (ffetch
 BITMAPWIDTH of
 (SETQ BITMAP (\DTEST BITMAP 'BITMAP]
    (BOUT16 FILE (ffetch
 BITMAPHEIGHT of
 BITMAP))
    (WRITEBINARYBITMAP
 BITMAP FILE])

(WRITEBMLST

  [LAMBDA (FILE LST)                                         (* JWogulis "26-Dec-84 15:06")

    (PROG [(F (OPENSTREAM FILE 'OUTPUT 'NEW]
          (for
 I in
 LST do
 (WRITEBM
 F I))
          (CLOSEF F])

(READBMLST

  [LAMBDA (FILE)                                             (* JWogulis "26-Dec-84 15:08")

    (bind
 (F _ (OPENSTREAM FILE 'INPUT 'OLD)) until
 (EOFP F) collect
 (READBM
 F)
       finally
 (CLOSEF F])

(READBM

  [LAMBDA (FILE)                                             (* lmm " 6-Jun-85 16:46")

    (READBINARYBITMAP
 (BIN16 FILE)
           (BIN16 FILE)
           FILE])

(READPRESS

  [LAMBDA (FILENAME)
                                         (* ; "Edited 24-Sep-2023 13:54 by rmk")

                                                             (* lmm " 2-Jun-86 22:34")

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

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

              (SETQ HT (BIN16 OFD))                          (* Height)

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

                              (RPCHK 2)                      (* Edotsize)

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

                            (BIN16 OFD)
                            (SETQ WIDTH (BIN16 OFD))
                            (RPCHK 0)
                            (RPCHK HT)
                            NIL)
                         (3 T)
                         (GO ERROR)))
              [\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)
          ERROR
              (ERROR "Sorry, unrecognized PRESS file format. READPRESS isn't very general.")))])

(WINDOWBM

  [LAMBDA (BITMAP POSITION)                                  (* JWogulis "26-Dec-84 15:37")

    (IF
 (AND POSITION (NOT (POSITIONP POSITION)))
        THEN
 (ERROR "NOT A POSITION" POSITION))
    [IF
 (NOT POSITION)
        THEN
 (SETQ POSITION (GETBOXPOSITION (IPLUS 8 (BITMAPWIDTH BITMAP))
                                   (IPLUS 8 (BITMAPHEIGHT BITMAP]
    (PROG ((WIND (CREATEW (LIST (CAR POSITION)
                                (CDR POSITION)
                                (IPLUS 8 (BITMAPWIDTH BITMAP))
                                (IPLUS 8 (BITMAPHEIGHT BITMAP)))
                        NIL 4)))
          (BITBLT BITMAP 0 0 WIND)
          (RETURN WIND])
)
(DECLARE%: DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(PUTPROPS RPCHK
 MACRO
 ((N)
                       (OR (EQ (BIN16 OFD)
                               N)
                           (GO ERROR))))
)
)
(PUTPROPS BITMAPFNS COPYRIGHT ("Xerox Corporation" 1983 1984 1985 1986))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (589 5676 (READBINARYBITMAP 599 . 1213) (WRITEBINARYBITMAP 1215 . 1585) (WRITEBM 1587 . 
1874) (WRITEBMLST 1876 . 2112) (READBMLST 2114 . 2351) (READBM 2353 . 2536) (READPRESS 2538 . 4970) (
WINDOWBM 4972 . 5674)))))
STOP