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

(FILECREATED " 6-Nov-92 09:25:48" {DSK}<project>medley2.0>lispusers>READBRUSH.;1
 9607   

      previous date%: "23-Jun-88 02:13:42" {DSK}<import>lisp>medley>lispusers>readbrush.;1)


(* ; "
Copyright (c) 1984, 1985, 1986, 1988, 1992 by Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT READBRUSHCOMS)

(RPAQQ READBRUSHCOMS

       ((FNS CHOOSE.IDLE.BITMAP READBRUSHFILE READBRUSH READROOTPICTURE IDLE.GLIDING.BOX)
        (FILES BITMAPFNS)
        [ADDVARS (IDLE.FUNCTIONS ("Gliding box" 'IDLE.GLIDING.BOX "moves images around on the screen"
                                        (SUBITEMS ("Pick image from MesaHacks" (PROGN (
                                                                                   CHOOSE.IDLE.BITMAP
                                                                                       )
                                                                                      
                                                                                      '
                                                                                     IDLE.GLIDING.BOX
                                                                                      ]
        (INITVARS (IDLE.BITMAP)
               (BRUSHMENU)
               (ROOTPICTUREMENU)
               (BRUSHDIRECTORY "{goofy:osbu north:xerox}<hacks>data>brushes>"))))
(DEFINEQ

(CHOOSE.IDLE.BITMAP

  [LAMBDA NIL
                                         (* ; "Edited 23-Jun-88 01:51 by masinter")

    (PROG NIL
          (ALLOW.BUTTON.EVENTS)
          (SETQ IDLE.BOUNCING.BOX
           (CAR (READBRUSHFILE
 (OR [MENU (OR BRUSHMENU
                                                 (SETQ BRUSHMENU
                                                  (create
 MENU
                                                         ITEMS _ (for
 FILE
                                                                    infiles
 (
                                                                               DIRECTORY.FILL.PATTERN
                                                                                 BRUSHDIRECTORY 
                                                                                 "brush" "")
                                                                    collect
 (NAMEFIELD FILE]
                                       (RETURN])

(READBRUSHFILE

  [LAMBDA (FILE)
                                         (* lmm "23-Jul-86 21:26")

    (OR (AND (LITATOM FILE)
             (GET FILE 'BRUSH))
        (PROG ((STR (OPENSTREAM (PACKFILENAME.STRING 'BODY FILE 'DIRECTORY BRUSHDIRECTORY
                                       'EXTENSION
                                       'BRUSH)
                           'INPUT
                           'OLD))
               M W H BM MASK REG)
              (BIN STR)
              (SETQ M (SELECTQ (BIN STR)
                          (1 T)
                          (0 NIL)
                          NIL))
              (SETQ W (BIN16 STR))
              (SETQ H (BIN16 STR))
              (RPTQ 10 (BIN STR))
              (SETQ BM (READBINARYBITMAP W H STR))
              (if
 M
                  then
 (SETQ MASK (READBINARYBITMAP W H STR)))
              (CLOSEF STR)
              (SETQ BM (CONS BM MASK))
              (IF
 (LITATOM FILE)
                  THEN
 (PUT FILE 'BRUSH BM))
              (RETURN BM])

(READBRUSH

  [LAMBDA (FILE)
                                         (* lmm " 4-Aug-85 07:31")

    (PROG ((BMS (READBRUSHFILE
 FILE))
           WIN REG)
          (if
 (CDR BMS)
              then
 (SETQ WIN (ICONW (CAR BMS)
                                        (CDR BMS)))
            else
 (MOVEW (SETQ WIN (CREATEWFROMIMAGE (CAR BMS)))
                            [fetch
 (REGION LEFT) of
 (SETQ REG (GETBOXREGION
                                                                       (WINDOWPROP WIN 'WIDTH)
                                                                       (WINDOWPROP WIN 'HEIGHT]
                            (fetch
 (REGION BOTTOM) of
 REG))
                  (OPENW WIN))
          (WINDOWPROP WIN 'BUTTONEVENTFN 'MOVEW)
          (RETURN WIN])

(READROOTPICTURE

  [LAMBDA (FILE)
                                         (* edited%: "17-May-85 19:21")

    (CHANGEBACKGROUND (READPRESS (PACKFILENAME.STRING 'BODY FILE 'DIRECTORY 
                                        "{GOOFY:OSBU NORTH}<HACKS>DATA>ROOTPICTURES>" 'EXTENSION
                                        'PRESS])

(IDLE.GLIDING.BOX

  [LAMBDA (WIN BITMAPS WAIT WAITSEQ MAXD)
             (* ; "Edited 23-Jun-88 01:53 by masinter")

    (OR BITMAPS (SETQ BITMAPS IDLE.BOUNCING.BOX))
    [OR WIN (SETQ WIN (OR POLYGONSWINDOW (SETQ POLYGONSWINDOW (CREATEW]
    (OR MAXD (SETQ MAXD 4))
    [SETQ BITMAPS (for
 X inside
 BITMAPS
                     collect
 (if
 (LITATOM X)
                                     then
 [OR (GETPROP X 'BITMAP)
                                                  (PUTPROP X 'BITMAP (OR (CAR (READBRUSHFILE

                                                                               X))
                                                                         (BITMAPCREATE 10 10]
                                   else
 (IDLE.BITMAP NIL X]
    (LET ((W (for
 X in
 BITMAPS largest
 (BITMAPWIDTH X) finally
 (RETURN $$EXTREME)))
          (H (for
 X in
 BITMAPS largest
 (BITMAPHEIGHT X) finally
 (RETURN $$EXTREME)))
          (REG (DSPCLIPPINGREGION NIL WIN)))
         (LET ((XBM (BITMAPCREATE (PLUS MAXD MAXD W)
                           (PLUS MAXD MAXD H)))
               (MAXX (MAX (DIFFERENCE (fetch
 WIDTH REG)
                                 (ADD1 W))
                          10))
               (MAXY (MAX (DIFFERENCE (fetch
 HEIGHT REG)
                                 (ADD1 W))
                          10))
               (MAXDD (FIX (SQRT MAXD)))
               X Y (CNT 0)
               DX DY STEPS NEWX NEWY REALX REALY ORIGX ORIGY TOY TOX THISBITMAP)
              (SETQ X (RAND 1 MAXX))
              (SETQ Y (RAND 1 MAXY))
              (BITBLT (SETQ THISBITMAP (CAR BITMAPS))
                     NIL NIL WIN X Y NIL NIL NIL 'INVERT)
              (while
 T do
 [COND
                                     ((ILEQ CNT 0)
                                      (SETQ ORIGX X)
                                      (SETQ ORIGY Y)
                                      (SETQ TOX (RAND 1 (SUB1 MAXX)))
                                      (SETQ TOY (RAND 1 (SUB1 MAXY)))
                                      (SETQ CNT (SETQ STEPS
                                                 (QUOTIENT (PLUS (MAX (ABS (DIFFERENCE TOX X))
                                                                      (ABS (DIFFERENCE TOY Y)))
                                                                 MAXD -1)
                                                        MAXD)))
                                      (QUOTIENT (PLUS (ABS (DIFFERENCE TOX X))
                                                      STEPS -1)
                                             STEPS))
                                     (T (SETQ CNT (SUB1 CNT]
                                 (SETQ NEWX (PLUS (QUOTIENT (TIMES CNT (DIFFERENCE ORIGX TOX))
                                                         STEPS)
                                                  TOX))
                                 (if
 (GREATERP (ABS (SETQ DX (DIFFERENCE NEWX X)))
                                                MAXD)
                                     then
 (SHOULDNT))
                                 (SETQ NEWY (PLUS (QUOTIENT (TIMES CNT (DIFFERENCE ORIGY TOY))
                                                         STEPS)
                                                  TOY))
                                 (if
 (GREATERP (ABS (SETQ DY (DIFFERENCE NEWY Y)))
                                                MAXD)
                                     then
 (SHOULDNT))
                                 (BITBLT NIL NIL NIL XBM NIL NIL NIL NIL 'TEXTURE 'ERASE BLACKSHADE)
                                 (BITBLT THISBITMAP NIL NIL XBM MAXD MAXD NIL NIL NIL 'INVERT)
                                 (BITBLT THISBITMAP NIL NIL XBM (PLUS MAXD DX)
                                        (PLUS MAXD DY)
                                        NIL NIL NIL 'INVERT)
                                 (BITBLT XBM NIL NIL WIN (DIFFERENCE X MAXD)
                                        (DIFFERENCE Y MAXD)
                                        NIL NIL NIL 'INVERT)
                                 (add
 X DX)
                                 (add
 Y DY)
                                 (DISMISS WAIT])
)

(FILESLOAD BITMAPFNS)

(ADDTOVAR IDLE.FUNCTIONS
 ["Gliding box" 'IDLE.GLIDING.BOX "moves images around on the screen"
                                    (SUBITEMS ("Pick image from MesaHacks" (PROGN (CHOOSE.IDLE.BITMAP
                                                                                   )
                                                                                  'IDLE.GLIDING.BOX])

(RPAQ? IDLE.BITMAP
 )

(RPAQ? BRUSHMENU
 )

(RPAQ? ROOTPICTUREMENU
 )

(RPAQ? BRUSHDIRECTORY
 "{goofy:osbu north:xerox}<hacks>data>brushes>")
(PUTPROPS READBRUSH COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1988 1992))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1444 8940 (CHOOSE.IDLE.BITMAP 1454 . 2452) (READBRUSHFILE 2454 . 3500) (READBRUSH 3502
 . 4314) (READROOTPICTURE 4316 . 4655) (IDLE.GLIDING.BOX 4657 . 8938)))))
STOP