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

(FILECREATED "11-Jun-90 15:42:25" {DSK}<usr>local>lde>lispcore>library>EDITBITMAP.;2
 19366  

      changes to%:  (VARS EDITBITMAPCOMS)

      previous date%: " 7-Oct-86 15:47:41" {DSK}<usr>local>lde>lispcore>library>EDITBITMAP.;1)


(* ; "
Copyright (c) 1983, 1984, 1985, 1986, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT EDITBITMAPCOMS)

(RPAQQ EDITBITMAPCOMS

       [(FNS ADD.BORDER.TO.BITMAP BIT.IN.COLUMN BIT.IN.ROW EDIT.BITMAP EDIT.BITMAP.REAL 
             FROM.SCREEN.BITMAP GET.EDIT.BITMAP.MENU INTERACT&SHIFT.BITMAP.LEFT 
             INTERACT&SHIFT.BITMAP.RIGHT INTERACT&SHIFT.BITMAP.DOWN INTERACT&SHIFT.BITMAP.UP 
             INTERACT&ADD.BORDER.TO.BITMAP INVERT.BITMAP.B/W INVERT.BITMAP.DIAGONALLY 
             INVERT.BITMAP.HORIZONTALLY INVERT.BITMAP.VERTICALLY ROTATE.BITMAP.LEFT 
             ROTATE.BITMAP.RIGHT SHIFT.BITMAP.DOWN SHIFT.BITMAP.LEFT SHIFT.BITMAP.RIGHT 
             SHIFT.BITMAP.UP TRIM.BITMAP)
        (VARS (EDIT.BITMAP.MENU))
        (GLOBALVARS EDIT.BITMAP.MENU PROMPTWINDOW BLACKSHADE)
        (FILES READNUMBER)
        (P (FONTCREATE '(GACHA 12 BOLD])
(DEFINEQ

(ADD.BORDER.TO.BITMAP

  [LAMBDA (BITMAP NBITS TEXTURE)
                         (* DAHJr "23-APR-83 12:23")

    (PROG ((WIDTH (fetch
 (BITMAP BITMAPWIDTH) of
 BITMAP))
           (HEIGHT (fetch
 (BITMAP BITMAPHEIGHT) of
 BITMAP))
           (REAL.NBITS (OR NBITS 2))
           NEW.BITMAP)
          [SETQ NEW.BITMAP (BITMAPCREATE (IPLUS WIDTH (ITIMES REAL.NBITS 2))
                                  (IPLUS HEIGHT (ITIMES REAL.NBITS 2]
          (BITBLT NIL NIL NIL NEW.BITMAP NIL NIL NIL NIL 'TEXTURE 'REPLACE (OR TEXTURE WHITESHADE))
          (BITBLT BITMAP 0 0 NEW.BITMAP REAL.NBITS REAL.NBITS WIDTH HEIGHT 'INPUT 'REPLACE)
          (RETURN NEW.BITMAP])

(BIT.IN.COLUMN

  [LAMBDA (BITMAP COLUMN)
                                (* AJB "11-Oct-85 16:07")

    (for
 X from
 0 to
 (SUB1 (fetch
 (BITMAP BITMAPHEIGHT) of
 BITMAP))
       when
 (EQ 1 (BITMAPBIT BITMAP COLUMN X)) DO
 (RETURN T])

(BIT.IN.ROW

  [LAMBDA (BITMAP ROW)
                                   (* AJB "11-Oct-85 16:11")

    (for
 X from
 0 to
 (SUB1 (fetch
 (BITMAP BITMAPWIDTH) of
 BITMAP))
       when
 (EQ 1 (BITMAPBIT BITMAP X ROW)) DO
 (RETURN T])

(EDIT.BITMAP

  [LAMBDA (OBJECT)
                                       (* AJB " 7-Oct-86 15:46")

    (PROG (NEW.OBJECT BM)
          (RETURN (COND
                     ((NULL OBJECT)
                      (EDIT.BITMAP.REAL
 (BITMAPCREATE 50 50)))
                     ((LITATOM OBJECT)
                      (SETQ BM (EVAL OBJECT))
                      (SETQ NEW.OBJECT (EDIT.BITMAP
 BM))
                      (SET OBJECT NEW.OBJECT)
                      OBJECT)
                     ((BITMAPP OBJECT)
                      (EDIT.BITMAP.REAL
 OBJECT))
                     ((CURSORP OBJECT)
                      (SETQ NEW.OBJECT (EDIT.BITMAP.REAL
 (fetch
 (CURSOR CUIMAGE) of

                                                                                         OBJECT)))
                      (CURSORCREATE NEW.OBJECT (fetch
 (CURSOR CUHOTSPOTX) of
 OBJECT)
                             (fetch
 (CURSOR CUHOTSPOTY) of
 OBJECT)))
                     (T (ERROR "Object of unrecognized type: " OBJECT])

(EDIT.BITMAP.REAL

  [LAMBDA (BITMAP)
                                       (* rrb "11-AUG-83 13:31")

    (PROG (NEW.BITMAP COMMAND.MENU DONE COMMAND PREVIOUS.BITMAP NAME TEMP X Y)
          (SETQ NEW.BITMAP (BITMAPCOPY BITMAP))
          (SETQ COMMAND.MENU (GET.EDIT.BITMAP.MENU
))
          [until
 DONE do
 (SETQ COMMAND (MENU COMMAND.MENU))
                                (CLEARW PROMPTWINDOW)
                                (SELECTQ COMMAND
                                    (NIL NIL)
                                    (QUIT (SETQ DONE T))
                                    (UNDO (COND
                                             (PREVIOUS.BITMAP (SETQ NEW.BITMAP (CAR PREVIOUS.BITMAP))
                                                    (SETQ PREVIOUS.BITMAP (CDR PREVIOUS.BITMAP)))
                                             (T (printout PROMPTWINDOW T 
                                                       "Can't: no previous bitmap saved"))))
                                    (PROGN (SETQ PREVIOUS.BITMAP (CONS NEW.BITMAP PREVIOUS.BITMAP))
                                           (SETQ NEW.BITMAP (SELECTQ COMMAND
                                                                (HAND.EDIT (EDITBM NEW.BITMAP))
                                                                (FROM.SCREEN (FROM.SCREEN.BITMAP
))
                                                                (TRIM (TRIM.BITMAP
 NEW.BITMAP))
                                                                (INVERT.HORIZONTALLY 
                                                                     (INVERT.BITMAP.HORIZONTALLY

                                                                      NEW.BITMAP))
                                                                (INVERT.VERTICALLY 
                                                                     (INVERT.BITMAP.VERTICALLY

                                                                      NEW.BITMAP))
                                                                (INVERT.DIAGONALLY 
                                                                     (INVERT.BITMAP.DIAGONALLY

                                                                      NEW.BITMAP))
                                                                (ROTATE.BITMAP.LEFT 
                                                                     (ROTATE.BITMAP.LEFT
 
                                                                            NEW.BITMAP))
                                                                (ROTATE.BITMAP.RIGHT 
                                                                     (ROTATE.BITMAP.RIGHT
 
                                                                            NEW.BITMAP))
                                                                (SHIFT.LEFT (

                                                                         INTERACT&SHIFT.BITMAP.LEFT

                                                                             NEW.BITMAP))
                                                                (SHIFT.RIGHT (

                                                                        INTERACT&SHIFT.BITMAP.RIGHT

                                                                              NEW.BITMAP))
                                                                (SHIFT.DOWN (

                                                                         INTERACT&SHIFT.BITMAP.DOWN

                                                                             NEW.BITMAP))
                                                                (SHIFT.UP (INTERACT&SHIFT.BITMAP.UP

                                                                           NEW.BITMAP))
                                                                (INTERCHANGE.BLACK/WHITE 
                                                                     (INVERT.BITMAP.B/W
 
                                                                            NEW.BITMAP))
                                                                (ADD.BORDER (

                                                                      INTERACT&ADD.BORDER.TO.BITMAP

                                                                             NEW.BITMAP))
                                                                (ERROR "Unrecognized command" COMMAND
                                                                       ]
          (RETURN NEW.BITMAP])

(FROM.SCREEN.BITMAP

  [LAMBDA NIL
                                            (* kbr%: "26-Feb-86 00:16")

    (PROG (SCREENREGION SCREEN REGION NEW.BITMAP)
          (printout PROMPTWINDOW T "Indicate a region from which to take bits")
          (SETQ SCREENREGION (GETSCREENREGION))
          (SETQ SCREEN (fetch
 (SCREENREGION SCREEN) of
 SCREENREGION))
          (SETQ REGION (fetch
 (SCREENREGION REGION) of
 SCREENREGION))
          [SETQ NEW.BITMAP (BITMAPCREATE (fetch
 (REGION WIDTH) of
 REGION)
                                  (fetch
 (REGION HEIGHT) of
 REGION)
                                  (BITSPERPIXEL (SCREENBITMAP SCREEN]
          (BITBLT (SCREENBITMAP SCREEN)
                 (fetch
 (REGION LEFT) of
 REGION)
                 (fetch
 (REGION BOTTOM) of
 REGION)
                 NEW.BITMAP 0 0 (fetch
 (REGION WIDTH) of
 REGION)
                 (fetch
 (REGION HEIGHT) of
 REGION)
                 'INPUT
                 'REPLACE)
          (RETURN NEW.BITMAP])

(GET.EDIT.BITMAP.MENU

  [LAMBDA NIL
                                            (* DAHJr " 7-JUL-83 17:13")

                                                             (* EVAL THIS WHEN CHANGING THE MENU

                                                           (SETQ EDIT.BITMAP.MENU))

    (OR EDIT.BITMAP.MENU
        (SETQ EDIT.BITMAP.MENU
         (create
 MENU
                TITLE _ "Operations on bitmaps"
                ITEMS _
                '(HAND.EDIT FROM.SCREEN TRIM INVERT.HORIZONTALLY INVERT.VERTICALLY INVERT.DIAGONALLY
                        ROTATE.BITMAP.LEFT ROTATE.BITMAP.RIGHT SHIFT.LEFT SHIFT.RIGHT SHIFT.DOWN 
                        SHIFT.UP INTERCHANGE.BLACK/WHITE ADD.BORDER UNDO QUIT)
                CENTERFLG _ T
                CHANGEOFFSETFLG _ T])

(INTERACT&SHIFT.BITMAP.LEFT

  [LAMBDA (BITMAP)
                                       (* edited%: "17-DEC-82 08:31")

    (PROG (NBITS NEW.BITMAP)
          (SETQ NBITS (RNUMBER "Number of bits to shift the bitmap left: "))
          (RETURN (SHIFT.BITMAP.LEFT
 BITMAP NBITS])

(INTERACT&SHIFT.BITMAP.RIGHT

  [LAMBDA (BITMAP)
                                       (* edited%: "17-DEC-82 08:31")

    (PROG (NBITS NEW.BITMAP)
          (SETQ NBITS (RNUMBER "Number of bits to shift the bitmap right: "))
          (RETURN (SHIFT.BITMAP.RIGHT
 BITMAP NBITS])

(INTERACT&SHIFT.BITMAP.DOWN

  [LAMBDA (BITMAP)
                                       (* DAHJr "23-MAR-83 14:39")

    (PROG (NBITS)
          (SETQ NBITS (RNUMBER "Number of bits to shift the bitmap down: "))
          (RETURN (SHIFT.BITMAP.DOWN
 BITMAP NBITS])

(INTERACT&SHIFT.BITMAP.UP

  [LAMBDA (BITMAP)
                                       (* edited%: "17-DEC-82 08:31")

    (PROG (NBITS NEW.BITMAP)
          (SETQ NBITS (RNUMBER "Number of bits to shift the bitmap up: "))
          (RETURN (SHIFT.BITMAP.UP
 BITMAP NBITS])

(INTERACT&ADD.BORDER.TO.BITMAP

  [LAMBDA (BITMAP)
                                       (* rrb "24-Jul-84 18:12")

    (PROG (NBITS TEXTURE)
          (COND
             ((EQ (SETQ NBITS (RNUMBER "Number of bits in the border: "))
                  0)
              (RETURN BITMAP))
             ((GREATERP 0 NBITS)
              (PROMPTPRINT "Can't add a negative border.")
              (RETURN BITMAP))
             ((GREATERP NBITS 500)
              (PROMPTPRINT "Can't add a border of more than 500.")
              (RETURN BITMAP)))
          (SETQ TEXTURE (EDITSHADE))
          (RETURN (ADD.BORDER.TO.BITMAP
 BITMAP NBITS TEXTURE])

(INVERT.BITMAP.B/W

  [LAMBDA (BITMAP)
                                       (* HK "12-JUL-82 11:19")

    (PROG ((WIDTH (fetch
 (BITMAP BITMAPWIDTH) of
 BITMAP))
           (HEIGHT (fetch
 (BITMAP BITMAPHEIGHT) of
 BITMAP))
           (NEW.BITMAP (BITMAPCOPY BITMAP)))
          (BITBLT BITMAP 0 0 NEW.BITMAP 0 0 WIDTH HEIGHT 'TEXTURE 'INVERT BLACKSHADE)
          (RETURN NEW.BITMAP])

(INVERT.BITMAP.DIAGONALLY

  [LAMBDA (BITMAP)
                                       (* HK "12-JUL-82 16:02")

    (PROG (NEW.BITMAP (WIDTH (fetch
 (BITMAP BITMAPWIDTH) of
 BITMAP))
                 (HEIGHT (fetch
 (BITMAP BITMAPHEIGHT) of
 BITMAP)))
          (SETQ NEW.BITMAP (BITMAPCREATE HEIGHT WIDTH))
          [for
 X from
 0 to
 (SUB1 WIDTH)
             do
 (for
 Y from
 0 to
 (SUB1 HEIGHT)
                       do
 (BITMAPBIT NEW.BITMAP Y X (BITMAPBIT BITMAP X Y]
          (RETURN NEW.BITMAP])

(INVERT.BITMAP.HORIZONTALLY

  [LAMBDA (BITMAP)
                                       (* HK "12-JUL-82 11:28")

    (PROG ((WIDTH (fetch
 (BITMAP BITMAPWIDTH) of
 BITMAP))
           (HEIGHT (fetch
 (BITMAP BITMAPHEIGHT) of
 BITMAP))
           (NEW.BITMAP (BITMAPCOPY BITMAP)))
          [for
 X1 from
 0 to
 (SUB1 (IQUOTIENT WIDTH 2))
             do
 (for
 Y from
 0 to
 (SUB1 HEIGHT)
                       bind
 (X2 _ (IDIFFERENCE (SUB1 WIDTH)
                                             X1)) do
 (BITMAPBIT NEW.BITMAP X1 Y
                                                                (BITMAPBIT BITMAP X2 Y))
                                                        (BITMAPBIT NEW.BITMAP X2 Y
                                                               (BITMAPBIT BITMAP X1 Y]
          (RETURN NEW.BITMAP])

(INVERT.BITMAP.VERTICALLY

  [LAMBDA (BITMAP)
                                       (* HK "12-JUL-82 11:33")

    (PROG ((WIDTH (fetch
 (BITMAP BITMAPWIDTH) of
 BITMAP))
           (HEIGHT (fetch
 (BITMAP BITMAPHEIGHT) of
 BITMAP))
           (NEW.BITMAP (BITMAPCOPY BITMAP)))
          [for
 X1 from
 0 to
 (SUB1 (IQUOTIENT HEIGHT 2))
             do
 (for
 Y from
 0 to
 (SUB1 WIDTH) bind
 (X2 _ (IDIFFERENCE
                                                                              (SUB1 HEIGHT)
                                                                              X1))
                       do
 (BITMAPBIT NEW.BITMAP Y X1 (BITMAPBIT BITMAP Y X2))
                             (BITMAPBIT NEW.BITMAP Y X2 (BITMAPBIT BITMAP Y X1]
          (RETURN NEW.BITMAP])

(ROTATE.BITMAP.LEFT

  [LAMBDA (BITMAP)
                                       (* HK "12-JUL-82 11:48")

    (PROG (NEW.BITMAP (WIDTH (fetch
 (BITMAP BITMAPWIDTH) of
 BITMAP))
                 (HEIGHT (fetch
 (BITMAP BITMAPHEIGHT) of
 BITMAP)))
          (SETQ NEW.BITMAP (BITMAPCREATE HEIGHT WIDTH))
          [for
 Y from
 0 to
 (SUB1 HEIGHT)
             do
 (for
 X from
 0 to
 (SUB1 WIDTH) bind
 (Y1 _ (IDIFFERENCE
                                                                              (SUB1 HEIGHT)
                                                                              Y))
                       do
 (BITMAPBIT NEW.BITMAP Y1 X (BITMAPBIT BITMAP X Y]
          (RETURN NEW.BITMAP])

(ROTATE.BITMAP.RIGHT

  [LAMBDA (BITMAP)
                                       (* HK "12-JUL-82 11:50")

    (PROG (NEW.BITMAP (WIDTH (fetch
 (BITMAP BITMAPWIDTH) of
 BITMAP))
                 (HEIGHT (fetch
 (BITMAP BITMAPHEIGHT) of
 BITMAP)))
          (SETQ NEW.BITMAP (BITMAPCREATE HEIGHT WIDTH))
          [for
 X from
 0 to
 (SUB1 WIDTH)
             do
 (for
 Y from
 0 to
 (SUB1 HEIGHT)
                       bind
 (X1 _ (IDIFFERENCE (SUB1 WIDTH)
                                             X)) do
 (BITMAPBIT NEW.BITMAP Y X1
                                                               (BITMAPBIT BITMAP X Y]
          (RETURN NEW.BITMAP])

(SHIFT.BITMAP.DOWN

  [LAMBDA (BITMAP NBITS)
                                 (* edited%: "21-OCT-82 16:20")

    (PROG ((WIDTH (fetch
 (BITMAP BITMAPWIDTH) of
 BITMAP))
           (HEIGHT (fetch
 (BITMAP BITMAPHEIGHT) of
 BITMAP))
           NEW.BITMAP)
          (SETQ NEW.BITMAP (BITMAPCREATE WIDTH (IPLUS HEIGHT NBITS)))
          (BITBLT BITMAP 0 0 NEW.BITMAP 0 0 WIDTH HEIGHT 'INPUT 'REPLACE)
          (RETURN NEW.BITMAP])

(SHIFT.BITMAP.LEFT

  [LAMBDA (BITMAP NBITS)
                                 (* edited%: "21-OCT-82 16:16")

    (PROG ((WIDTH (fetch
 (BITMAP BITMAPWIDTH) of
 BITMAP))
           (HEIGHT (fetch
 (BITMAP BITMAPHEIGHT) of
 BITMAP))
           NEW.BITMAP)
          (SETQ NEW.BITMAP (BITMAPCREATE (IPLUS WIDTH NBITS)
                                  HEIGHT))
          (BITBLT BITMAP 0 0 NEW.BITMAP 0 0 WIDTH HEIGHT 'INPUT 'REPLACE)
          (RETURN NEW.BITMAP])

(SHIFT.BITMAP.RIGHT

  [LAMBDA (BITMAP NBITS)
                                 (* edited%: "21-OCT-82 16:17")

    (PROG ((WIDTH (fetch
 (BITMAP BITMAPWIDTH) of
 BITMAP))
           (HEIGHT (fetch
 (BITMAP BITMAPHEIGHT) of
 BITMAP))
           NEW.BITMAP)
          (SETQ NEW.BITMAP (BITMAPCREATE (IPLUS WIDTH NBITS)
                                  HEIGHT))
          (BITBLT BITMAP 0 0 NEW.BITMAP NBITS 0 WIDTH HEIGHT 'INPUT 'REPLACE)
          (RETURN NEW.BITMAP])

(SHIFT.BITMAP.UP

  [LAMBDA (BITMAP NBITS)
                                 (* edited%: "21-OCT-82 16:18")

    (PROG ((WIDTH (fetch
 (BITMAP BITMAPWIDTH) of
 BITMAP))
           (HEIGHT (fetch
 (BITMAP BITMAPHEIGHT) of
 BITMAP))
           NEW.BITMAP)
          (SETQ NEW.BITMAP (BITMAPCREATE WIDTH (IPLUS HEIGHT NBITS)))
          (BITBLT BITMAP 0 0 NEW.BITMAP 0 NBITS WIDTH HEIGHT 'INPUT 'REPLACE)
          (RETURN NEW.BITMAP])

(TRIM.BITMAP

  [LAMBDA (BITMAP)
                                       (* HK "20-JUL-82 15:59")

    (PROG ((WIDTH (fetch
 (BITMAP BITMAPWIDTH) of
 BITMAP))
           (HEIGHT (fetch
 (BITMAP BITMAPHEIGHT) of
 BITMAP))
           LEFT RIGHT BOTTOM TOP NEW.BITMAP)
          (SETQ LEFT (for
 X from
 0 to
 (SUB1 WIDTH) thereis
 (BIT.IN.COLUMN
 BITMAP
                                                                                  X)))
          (SETQ RIGHT (for
 X from
 (SUB1 WIDTH) to
 0 by
 -1
                         thereis
 (BIT.IN.COLUMN
 BITMAP X)))
          (SETQ BOTTOM (for
 X from
 0 to
 (SUB1 HEIGHT) thereis
 (BIT.IN.ROW
 BITMAP
                                                                                     X)))
          (SETQ TOP (for
 X from
 (SUB1 HEIGHT) to
 0 by
 -1
                       thereis
 (BIT.IN.ROW
 BITMAP X)))
          (OR (AND LEFT RIGHT BOTTOM TOP)
              (HELP))
          [SETQ NEW.BITMAP (BITMAPCREATE (ADD1 (IDIFFERENCE RIGHT LEFT))
                                  (ADD1 (IDIFFERENCE TOP BOTTOM]
          (BITBLT BITMAP LEFT BOTTOM NEW.BITMAP 0 0 (ADD1 (IDIFFERENCE RIGHT LEFT))
                 (ADD1 (IDIFFERENCE TOP BOTTOM))
                 'INPUT
                 'REPLACE)
          (RETURN NEW.BITMAP])
)

(RPAQQ EDIT.BITMAP.MENU
 NIL)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS EDIT.BITMAP.MENU PROMPTWINDOW BLACKSHADE)
)

(FILESLOAD READNUMBER)

(FONTCREATE '(GACHA 12 BOLD))
(PUTPROPS EDITBITMAP COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1199 19075 (ADD.BORDER.TO.BITMAP 1209 . 1891) (BIT.IN.COLUMN 1893 . 2160) (BIT.IN.ROW 
2162 . 2422) (EDIT.BITMAP 2424 . 3474) (EDIT.BITMAP.REAL 3476 . 8053) (FROM.SCREEN.BITMAP 8055 . 9103)
 (GET.EDIT.BITMAP.MENU 9105 . 9912) (INTERACT&SHIFT.BITMAP.LEFT 9914 . 10203) (
INTERACT&SHIFT.BITMAP.RIGHT 10205 . 10497) (INTERACT&SHIFT.BITMAP.DOWN 10499 . 10774) (
INTERACT&SHIFT.BITMAP.UP 10776 . 11059) (INTERACT&ADD.BORDER.TO.BITMAP 11061 . 11715) (
INVERT.BITMAP.B/W 11717 . 12125) (INVERT.BITMAP.DIAGONALLY 12127 . 12679) (INVERT.BITMAP.HORIZONTALLY 
12681 . 13549) (INVERT.BITMAP.VERTICALLY 13551 . 14375) (ROTATE.BITMAP.LEFT 14377 . 15126) (
ROTATE.BITMAP.RIGHT 15128 . 15829) (SHIFT.BITMAP.DOWN 15831 . 16281) (SHIFT.BITMAP.LEFT 16283 . 16767)
 (SHIFT.BITMAP.RIGHT 16769 . 17258) (SHIFT.BITMAP.UP 17260 . 17712) (TRIM.BITMAP 17714 . 19073)))))
STOP