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

(FILECREATED " 5-Dec-2020 16:36:45" 
{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>SCREENPAPER.;3
 12813  

      previous date%: "17-Aug-90 14:46:25" 
{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>SCREENPAPER.;1)


(* ; "
Copyright (c) 1901, 1986, 1988, 1990, 2020 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT SCREENPAPERCOMS)

(RPAQQ SCREENPAPERCOMS

       ((FNS SCREENPAPER SCREENPAPERNEWREGIONFN KALSHOW DOPOINT MAPN)
        [ADDVARS (IDLE.FUNCTIONS ("Screen wallpaper" 'SCREENPAPER]
        

(* ;;; "faster versions of editbitmap functions")


        (FNS INVERT.BITMAP.HORIZONTALLY INVERT.BITMAP.VERTICALLY ROTATE.BITMAP)
        (VARS SCREENPAPERSIZE SCREENPERIOD SCREENREPEAT)))
(DEFINEQ

(SCREENPAPER

  [LAMBDA (WINDOW REGION.OR.SIZE OPTION)
                 (* ; "Edited  9-Sep-88 17:05 by bmw")

    (OR WINDOW (SETQ WINDOW (CREATEW)))
    (OR REGION.OR.SIZE (SETQ REGION.OR.SIZE (if
 (EQ OPTION 'PICK)
                                                then
 (GETREGION 16 16 NIL (FUNCTION 
                                                                               SCREENPAPERNEWREGIONFN
                                                                               ))
                                              else
 SCREENPAPERSIZE)))
    (LET ((SIZE (if
 (REGIONP REGION.OR.SIZE)
                    then
 (fetch
 (REGION WIDTH)
                                    REGION.OR.SIZE)
                  else
 REGION.OR.SIZE))
          TRIANGLE STREAM BUF1 2SIZE BIGBUF PBT BUF1A BUF2 BUF3 BUF4 CX CY (CNT SCREENPERIOD))
         (DECLARE
 (SPECVARS TRIANGLE STREAM BUF1 2SIZE BIGBUF PBT BUF1A BUF2 BUF3 BUF4 CX CY CNT)
                )
         (SETQ TRIANGLE (BITMAPCREATE SIZE SIZE))
         (SETQ BUF1 (BITMAPCREATE SIZE SIZE))
         (SETQ STREAM (DSPCREATE TRIANGLE))
         (FILLPOLYGON (LIST '(-1 . -1)
                            (CONS SIZE SIZE)
                            (CONS -1 SIZE))
                BLACKSHADE STREAM)
         (SETQ BUF2 (BITMAPCREATE SIZE SIZE))
         (SETQ BUF3 (BITMAPCREATE SIZE SIZE))
         (SETQ 2SIZE (PLUS SIZE SIZE))
         (SETQ BIGBUF (BITMAPCREATE 2SIZE 2SIZE))
         (SETQ PBT (create
 PILOTBBT))
         (DSPDESTINATION BUF1 STREAM)
         (if
 (EQ OPTION 'PICK)
             then
 (bind
 POS do
 [RESETFORM (CURSOR CROSSHAIRS)
                                                  (until
 (MOUSESTATE (OR LEFT MIDDLE RIGHT]
                                          (if
 (LASTMOUSESTATE (ONLY MIDDLE))
                                              then
 (RETURN BIGBUF)
                                            elseif
 (LASTMOUSESTATE (ONLY RIGHT))
                                              then
 (RETURN NIL)
                                            elseif
 (REGIONP REGION.OR.SIZE)
                                              then
 (SETQ POS (CONS (fetch
 (REGION LEFT)
                                                                              REGION.OR.SIZE)
                                                                       (fetch
 (REGION BOTTOM)
                                                                              REGION.OR.SIZE)))
                                                    (SETQ REGION.OR.SIZE)
                                            else
 (SETQ POS (GETBOXPOSITION SIZE SIZE)))
                                          (BITBLT (SCREENBITMAP)
                                                 (CAR POS)
                                                 (CDR POS)
                                                 BUF1 0 0 SIZE SIZE)
                                          (KALSHOW
 BUF1 WINDOW SIZE
                                                 (if
 (SHIFTDOWNP 'SHIFT)
                                                     then
 'INVERT
                                                   else
 NIL)))
           else
 (MAPN
 WINDOW (FUNCTION (LAMBDA (X Y)
                                                 (BITBLT (WINDOWPROP WINDOW 'IMAGECOVERED)
                                                        X Y BUF1 0 0 SIZE SIZE)
                                                 (DRAWLINE (SUB1 SIZE)
                                                        0
                                                        (RAND 0 (SUB1 SIZE))
                                                        (RAND 0 (SUB1 SIZE))
                                                        1
                                                        'INVERT STREAM)
                                                 (KALSHOW
 BUF1 WINDOW SIZE
                                                        (if
 (VIDEOCOLOR)
                                                            then
 NIL
                                                          else
 'INVERT))
                                                 (if
 (LEQ (add
 CNT -1)
                                                              0)
                                                     then
 (SETQ CNT SCREENPERIOD)
                                                           (to
 SCREENREPEAT
                                                              do
 (BITBLT WINDOW 0 0 BUF1)
                                                                    (KALSHOW
 BUF1 WINDOW SIZE])

(SCREENPAPERNEWREGIONFN

(LAMBDA (FP MP) (* BN "17-Sep-84 10:40") (COND (MP (with POSITION MP (PROG ((DX (IDIFFERENCE XCOORD (fetch (POSITION XCOORD) of FP))) (DY (IDIFFERENCE YCOORD (fetch (POSITION YCOORD) of FP)))) (COND ((IGREATERP (IABS DX) (IABS DY)) (SETQ YCOORD (IPLUS (fetch (POSITION YCOORD) of FP) (ITIMES DX (COND ((MINUSP (ITIMES DX DY)) -1) (T 1)))))) (T (SETQ XCOORD (IPLUS (fetch (POSITION XCOORD) of FP) (ITIMES DY (COND ((MINUSP (ITIMES DX DY)) -1) (T 1))))))) (RETURN MP)))) (T FP)))
)

(KALSHOW

(LAMBDA (BUF1 WINDOW SIZE MODE) (* ; "Edited  5-Aug-88 11:54 by drc:") (BITBLT TRIANGLE NIL NIL BUF1 NIL NIL NIL NIL NIL (QUOTE ERASE)) (* THAT ERASED ALL BUT THE TRIANGLE) (ROTATE.BITMAP BUF1 BUF2 PBT) (INVERT.BITMAP.VERTICALLY BUF2 BUF3 PBT) (BITBLT BUF3 NIL NIL BUF1 NIL NIL NIL NIL NIL (QUOTE PAINT)) (LET (CX CY) (BITBLT BUF1 NIL NIL BIGBUF 0 SIZE) (INVERT.BITMAP.HORIZONTALLY BUF1 BUF2 PBT) (BITBLT BUF2 NIL NIL BIGBUF SIZE SIZE) (INVERT.BITMAP.VERTICALLY BUF1 BUF3 PBT) (BITBLT BUF3 NIL NIL BIGBUF 0 0) (INVERT.BITMAP.HORIZONTALLY BUF3 BUF2 PBT) (BITBLT BUF2 NIL NIL BIGBUF SIZE 0) (SETQ CX (QUOTIENT (WINDOWPROP WINDOW (QUOTE WIDTH)) 2)) (SETQ CY (QUOTIENT (WINDOWPROP WINDOW (QUOTE HEIGHT)) 2)) (for I from 0 while (LESSP I (QUOTIENT (PLUS 2SIZE (MAX CX CY)) 2SIZE)) do (for J from 0 while (LEQ J I) do (DOPOINT (FUNCTION (LAMBDA (X Y) (BITBLT BIGBUF NIL NIL WINDOW (PLUS CX (TIMES X 2SIZE)) (PLUS CY (TIMES Y 2SIZE)) NIL NIL MODE (QUOTE REPLACE)))) J I))) (BLOCK)))
)

(DOPOINT

  [LAMBDA (FN X Y)
                                           (* edited%: "31-Dec-00 16:08")

    (if
 (LESSP X Y)
        then
 (DOPOINT
 FN Y X))
    (APPLY* FN X Y 1)
    (APPLY* FN (DIFFERENCE -1 X)
           Y 1)
    (APPLY* FN X (DIFFERENCE -1 Y)
           1)
    (APPLY* FN (DIFFERENCE -1 X)
           (DIFFERENCE -1 Y)
           1])

(MAPN

  [LAMBDA (WINDOW FN)
                                        (* edited%: " 1-Jan-01 00:09")

    (LET ((MAXX (DIFFERENCE (WINDOWPROP WINDOW 'WIDTH)
                       SIZE))
          (MAXY (DIFFERENCE (WINDOWPROP WINDOW 'HEIGHT)
                       SIZE))
          X Y NX NY STEPS)
         (SETQ X (RAND 0 MAXX))
         (SETQ Y (RAND 0 MAXY))
         (while
 T do
 (SETQ NX (RAND 0 MAXX))
                     (SETQ NY (RAND 0 MAXY))
                     (SETQ STEPS (QUOTIENT (PLUS (ABS (DIFFERENCE NX X))
                                                 (ABS (DIFFERENCE NY Y)))
                                        4))
                     (if
 (NEQ STEPS 0)
                         then
 [for
 I from
 1 to
 STEPS
                                 do
 (APPLY* FN (PLUS X (QUOTIENT (TIMES (DIFFERENCE NX X)
                                                                        I)
                                                              STEPS))
                                           (PLUS Y (QUOTIENT (TIMES (DIFFERENCE NY Y)
                                                                    I)
                                                          STEPS]
                              (SETQ X NX)
                              (SETQ Y NY])
)

(ADDTOVAR IDLE.FUNCTIONS
 ("Screen wallpaper" 'SCREENPAPER))



(* ;;; "faster versions of editbitmap functions")


(DEFINEQ

(INVERT.BITMAP.HORIZONTALLY

  [LAMBDA (BITMAP BM2 PBT)
                                   (* edited%: "31-Dec-00 17:15")

    (OR BM2 (SETQ BM2 (BITMAPCOPY BITMAP)))
    (OR PBT (SETQ PBT (create
 PILOTBBT)))
    (with
 PILOTBBT PBT (SETQ PBTDESTLO (ffetch
 BitMapLoLoc BM2))
          (SETQ PBTDESTHI (ffetch
 BitMapHiLoc BM2))
          (SETQ PBTSOURCELO (ffetch
 BitMapLoLoc BITMAP))
          (SETQ PBTSOURCEHI (ffetch
 BitMapHiLoc BITMAP))
          (SETQ PBTDESTBPL (TIMES 16 (ffetch
 BITMAPRASTERWIDTH BM2)))
          (SETQ PBTSOURCEBPL (TIMES 16 (ffetch
 BITMAPRASTERWIDTH BITMAP)))
          (SETQ PBTFLAGS 16384)                              (* by experiment, disjoint replace)

          (SETQ PBTHEIGHT (ffetch
 BITMAPHEIGHT BITMAP))
          (SETQ PBTWIDTH 1)
          (for
 I from
 0 while
 (LESSP I (ffetch
 BITMAPWIDTH BITMAP))
             do
 (SETQ PBTSOURCEBIT I)
                (SETQ PBTDESTBIT (DIFFERENCE (SUB1 (ffetch
 BITMAPWIDTH BITMAP))
                                        I))
                (\PILOTBITBLT PBT 0)))
    BM2])

(INVERT.BITMAP.VERTICALLY

  [LAMBDA (BITMAP BM2 PBT)
                                   (* edited%: "31-Dec-00 18:13")

    (OR BM2 (SETQ BM2 (BITMAPCOPY BITMAP)))
    (OR PBT (SETQ PBT (create
 PILOTBBT)))
    [with
 PILOTBBT PBT                                       (*)

          (SETQ PBTDESTHI (ffetch
 BitMapHiLoc BM2))
          [SETQ PBTDESTLO (PLUS (ffetch
 BitMapLoLoc BM2)
                                (TIMES (SUB1 (ffetch
 BITMAPHEIGHT BITMAP))
                                       (ffetch
 BITMAPRASTERWIDTH BM2]
          (SETQ PBTSOURCELO (ffetch
 BitMapLoLoc BITMAP))
          (SETQ PBTSOURCEHI (ffetch
 BitMapHiLoc BITMAP))
          (SETQ PBTDESTBPL (TIMES 16 (ffetch
 BITMAPRASTERWIDTH BM2)))
          (SETQ PBTSOURCEBPL (TIMES 16 (ffetch
 BITMAPRASTERWIDTH BITMAP)))
          (SETQ PBTSOURCEBIT 0)
          (SETQ PBTDESTBIT 0)
          (SETQ PBTFLAGS 16384)                              (* by experiment, disjoint replace)

          (SETQ PBTHEIGHT 1)
          (SETQ PBTWIDTH (ffetch
 BITMAPWIDTH BITMAP))
          (for
 I from
 0 while
 (LESSP I (ffetch
 BITMAPHEIGHT BITMAP))
             do
 (\PILOTBITBLT PBT 0)
                (add
 PBTSOURCELO (ffetch
 BITMAPRASTERWIDTH BITMAP))
                (add
 PBTDESTLO (MINUS (ffetch
 BITMAPRASTERWIDTH BM2]
    BM2])

(ROTATE.BITMAP

  [LAMBDA (BITMAP BM2 PBT)
                                   (* edited%: "31-Dec-00 16:24")

    [OR BM2 (SETQ BM2 (BITMAPCREATE (ffetch
 BITMAPHEIGHT BITMAP)
                             (ffetch
 BITMAPWIDTH BITMAP]
    (OR PBT (SETQ PBT (create
 PILOTBBT)))
    [with
 PILOTBBT PBT                                       (*)

          (SETQ PBTDESTHI (ffetch
 BitMapHiLoc BM2))
          (SETQ PBTDESTLO (ffetch
 BitMapLoLoc BM2))
          (SETQ PBTSOURCELO (ffetch
 BitMapLoLoc BITMAP))
          (SETQ PBTSOURCEHI (ffetch
 BitMapHiLoc BITMAP))
          (SETQ PBTDESTBPL (TIMES 16 (ffetch
 BITMAPRASTERWIDTH BM2)))
          (SETQ PBTSOURCEBPL 1)
          (SETQ PBTSOURCEBIT 0)
          (SETQ PBTDESTBIT (ffetch
 BITMAPWIDTH BM2))
          (SETQ PBTFLAGS 0)                                  (* by experiment, disjoint replace)

          (SETQ PBTHEIGHT (ffetch
 BITMAPHEIGHT BM2))
          (SETQ PBTWIDTH 1)
          (for
 I from
 0 while
 (LESSP I (ffetch
 BITMAPHEIGHT BITMAP))
             do
 (add
 PBTDESTBIT -1)
                (\PILOTBITBLT PBT 0)
                (add
 PBTSOURCELO (ffetch
 BITMAPRASTERWIDTH BITMAP]
    BM2])
)

(RPAQQ SCREENPAPERSIZE
 64)

(RPAQQ SCREENPERIOD
 100)

(RPAQQ SCREENREPEAT
 0)
(PUTPROPS SCREENPAPER COPYRIGHT ("Venue & Xerox Corporation" 1901 1986 1988 1990 2020))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (851 8746 (SCREENPAPER 861 . 5549) (SCREENPAPERNEWREGIONFN 5551 . 6058) (KALSHOW 6060 . 
7050) (DOPOINT 7052 . 7424) (MAPN 7426 . 8744)) (8870 12612 (INVERT.BITMAP.HORIZONTALLY 8880 . 9997) (
INVERT.BITMAP.VERTICALLY 9999 . 11375) (ROTATE.BITMAP 11377 . 12610)))))
STOP