(FILECREATED "29-Dec-86 16:36:18" {ERIS}<LISPUSERS>KOTO>SCREENPAPER.;1 9048
previous date: "30-Nov-86 12:46:11" {ERIS}<LISPUSERS>LISPCORE>SCREENPAPER.;1)
(* Copyright (c) 1901, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT SCREENPAPERCOMS)
(RPAQQ SCREENPAPERCOMS ((FNS SCREENPAPER 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 SIZE OPTION) (* ; "Edited 30-Nov-86 12:41 by lmm")
(OR WINDOW (SETQ WINDOW (CREATEW)))
(OR SIZE (SETQ SIZE SCREENPAPERSIZE))
(LET (TRIANGLE STREAM BUF1 2SIZE BIGBUF PBT BUF1A BUF2 BUF3 BUF4 CX CY (CNT SCREENPERIOD))
(SETQ TRIANGLE (BITMAPCREATE SIZE SIZE))
(SETQ BUF1 (BITMAPCREATE SIZE SIZE))
(SETQ STREAM (DSPCREATE TRIANGLE))
(FILLPOLYGON (LIST (QUOTE (-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 (QUOTE PICK))
then (while T bind POS
do (SETQ POS (GETBOXPOSITION SIZE SIZE))
(BITBLT (SCREENBITMAP)
(CAR POS)
(CDR POS)
BUF1 0 0 SIZE SIZE)
(KALSHOW BUF1 WINDOW SIZE))
else (MAPN WINDOW (FUNCTION (LAMBDA (X Y)
(BITBLT (WINDOWPROP WINDOW (QUOTE IMAGECOVERED))
X Y BUF1 0 0 SIZE SIZE)
(DRAWLINE (SUB1 SIZE)
0
(RAND 0 (SUB1 SIZE))
(RAND 0 (SUB1 SIZE))
1
(QUOTE INVERT)
STREAM)
(KALSHOW BUF1 WINDOW SIZE)
(if (LEQ (add CNT -1)
0)
then (SETQ CNT SCREENPERIOD)
(to SCREENREPEAT
do (BITBLT WINDOW 0 0 BUF1)
(KALSHOW BUF1 WINDOW SIZE])
(KALSHOW
[LAMBDA (BUF1 WINDOW SIZE) (* edited: " 1-Jan-01 01:04")
(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]
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 (QUOTE WIDTH))
SIZE))
(MAXY (DIFFERENCE (WINDOWPROP WINDOW (QUOTE 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 ("Xerox Corporation" 1901 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (596 5134 (SCREENPAPER 606 . 2399) (KALSHOW 2401 . 3780) (DOPOINT 3782 . 4162) (MAPN
4164 . 5132)) (5252 8871 (INVERT.BITMAP.HORIZONTALLY 5262 . 6355) (INVERT.BITMAP.VERTICALLY 6357 .
7680) (ROTATE.BITMAP 7682 . 8869)))))
STOP