(FILECREATED " 3-Apr-86 11:19:34" {PHYLUM}<STANSBURY>MISC>BACKGROUNDIMAGES.;5 13375
changes to: (VARS BACKGROUNDIMAGESCOMS)
(FNS BACKGROUND.MODE BACKGROUND.SETUP BACKGROUND.FETCH BACKGROUND.REFLECT
BACKGROUND.TILE BACKGROUND.CENTER BACKGROUND.LESS BACKGROUND.FILES
BACKGROUND.FILE BACKGROUND.SHORTNAME)
previous date: "31-Jan-86 16:21:55" {PHYLUM}<LISPUSERS>KOTO>BACKGROUNDIMAGES.;2)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT BACKGROUNDIMAGESCOMS)
(RPAQQ BACKGROUNDIMAGESCOMS [(* * Enables you to load interesting backgrounds. Simplest entry is
just to call (BACKGROUND.SETUP))
(FNS BACKGROUND.SETUP BACKGROUND.FILES BACKGROUND.FILE
BACKGROUND.FETCH BACKGROUND.SHORTNAME BACKGROUND.MODE)
(FNS BACKGROUND.CENTER BACKGROUND.REFLECT BACKGROUND.TILE
BACKGROUND.LESS)
(INITVARS (BACKGROUNDS NIL)
(BACKGROUND.MODE (QUOTE CENTER)))
(GLOBALVARS BACKGROUNDS BackgroundMenuCommands LISPUSERSDIRECTORIES
BACKGROUND.MODE)
[ADDVARS (GAINSPACEFORMS ((LISTP BACKGROUNDS)
"Delete saved background bitmaps"
(SETQ BACKGROUNDS NIL]
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA BACKGROUND.MODE])
(* * Enables you to load interesting backgrounds. Simplest entry is just to call (
BACKGROUND.SETUP))
(DEFINEQ
(BACKGROUND.SETUP
[LAMBDA (NAMES) (* hts: " 2-Apr-86 12:15")
(* * Background decoration. Puts stuff on the background menu that will let you stick up fun backgrounds on the
screen.)
(LET [(IMAGES (if (LISTP NAMES)
then NAMES
else (BACKGROUND.FILES NAMES]
(if (LISTP IMAGES)
then (FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES)
BACKGROUNDMENU)
(BkgMenu.remove.item (QUOTE Background))
[BkgMenu.add.item
(LIST (QUOTE Background)
(QUOTE (QUOTE (CHANGEBACKGROUND)))
"Change background"
(CONS (QUOTE SUBITEMS)
(for IMAGE in IMAGES
collect (LET ((NAME (if (LISTP IMAGE)
then (CAR IMAGE)
else IMAGE))
(FILENAME (if (LISTP IMAGE)
then (CDR IMAGE)
else NIL)))
(LIST NAME
(BQUOTE (QUOTE
(BACKGROUND.FETCH
(QUOTE , NAME)
(QUOTE , FILENAME)
BACKGROUND.MODE)))
(CONCAT "Change background to "
NAME]
(BkgMenu.fixup)
T
else NIL])
(BACKGROUND.FILES
[LAMBDA (WHICH) (* hts: "31-Mar-86 13:29")
(* * Returns a list of names of press files which contain background-sized images)
(for filename in [SELECTQ WHICH
[T
(* * Find all images on all lispusersdirectories)
(for DIR in LISPUSERSDIRECTORIES bind IMAGES
first (SETQ IMAGES NIL)
do (for image in (APPEND (FILDIR (PACK* DIR
"background-*.bitmap"))
(FILDIR (PACK* DIR
"background-*.press")))
do (pushnew IMAGES image))
finally (RETURN (SORT IMAGES]
(PROGN
(* * Find just the clump of images on the first lispusersdirectory that has any images on it.
(Useful because usually images will be on just one lispusersdirectory.))
(for DIR in LISPUSERSDIRECTORIES
do (LET [(images (APPEND (FILDIR (PACK*
DIR
"background-*.bitmap"))
(FILDIR (PACK*
DIR
"background-*.press"]
(if (LISTP images)
then (RETURN images]
collect (CONS (BACKGROUND.SHORTNAME filename)
filename])
(BACKGROUND.FILE
[LAMBDA (NAME) (* hts: "31-Mar-86 13:09")
(* * Finds the file containing a press encoding of the named background.)
(for DIR in LISPUSERSDIRECTORIES do (LET ((BITMAP.FILENAME (PACKFILENAME (QUOTE
DIRECTORY)
DIR
(QUOTE NAME)
(CONCAT
"background-"
NAME)
(QUOTE
EXTENSION)
"bitmap"))
(PRESS.FILENAME (PACKFILENAME (QUOTE
DIRECTORY)
DIR
(QUOTE NAME)
(CONCAT
"background-"
NAME)
(QUOTE
EXTENSION)
"press")))
(if (INFILEP BITMAP.FILENAME)
then (RETURN BITMAP.FILENAME)
elseif (INFILEP PRESS.FILENAME)
then (RETURN PRESS.FILENAME])
(BACKGROUND.FETCH
[LAMBDA (NAME FILENAME MODE) (* hts: " 2-Apr-86 12:35")
(* * Puts up the specified background. If it is cached, just grabs it off the cache; else reads the press file off
the server, translates it into a bitmap, slams it up, and caches it.)
(LET ((BITMAP (LISTGET BACKGROUNDS NAME)))
[if (NOT (BITMAPP BITMAP))
then
(* * Find background: either off a Lisp bitmap file, or off an old Press file)
(CLRPROMPT)
(PRINTOUT PROMPTWINDOW "Fetching background " NAME " ... ")
(if (NULL FILENAME)
then (SETQ FILENAME (BACKGROUND.FILE NAME)))
(if (OR (NULL FILENAME)
(NOT (INFILEP FILENAME)))
then (PROMPTPRINT "Background " FILENAME " not available.")
else (if (PRESSFILEP FILENAME)
then (FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES)
BITMAPFNS)
(SETQ BITMAP (READPRESS FILENAME))
else (LET [(STREAM (OPENSTREAM FILENAME (QUOTE INPUT]
(SETQ BITMAP (HREAD STREAM))
(CLOSEF STREAM)))
(PRINTOUT PROMPTWINDOW "done." T)
(* * Cache it (before modifying it))
(if (LISTP BACKGROUNDS)
then (LISTPUT BACKGROUNDS NAME BITMAP)
else (SETQ BACKGROUNDS (LIST NAME BITMAP]
(* * Adjust bitmap and apply to background of screen)
(PRINTOUT PROMPTWINDOW "Adjusting background ... ")
(SETQ BITMAP (SELECTQ MODE
(TILE (BACKGROUND.TILE BITMAP))
(REFLECT (BACKGROUND.REFLECT BITMAP))
((NIL CENTER)
(BACKGROUND.CENTER BITMAP))
(\ILLEGAL.ARG MODE)))
(CHANGEBACKGROUND BITMAP)
(PRINTOUT PROMPTWINDOW "done." T)
BITMAP])
(BACKGROUND.SHORTNAME
[LAMBDA (IMAGE) (* hts: "31-Jan-86 16:14")
(* * Parses the IMAGE file name to find the short name of a background. IMAGE file names are of the form
{server}<directory>SHORTNAME-background.press)
(MKATOM (L-CASE (LET [(LONGNAME (FILENAMEFIELD IMAGE (QUOTE NAME]
(SUBSTRING LONGNAME (LET ((start (STRPOS "-" LONGNAME)))
(if (FIXP start)
then (ADD1 start)
else start))
NIL))
T])
(BACKGROUND.MODE
[LAMBDA NEWVAL (* hts: " 2-Apr-86 12:41")
(* * Finds the value of or resets the background image applying mode.)
(if (EQ 0 NEWVAL)
then BACKGROUND.MODE
else (OR (FMEMB (ARG NEWVAL 1)
(QUOTE (CENTER TILE REFLECT)))
(\ILLEGAL.ARG (ARG NEWVAL 1)))
(PROG1 BACKGROUND.MODE (SETQ BACKGROUND.MODE (ARG NEWVAL 1])
)
(DEFINEQ
(BACKGROUND.CENTER
[LAMBDA (BITMAP) (* hts: " 1-Apr-86 15:37")
(* * Returns a new bitmap the size of the screen which has the argument bitmap centered in it and a white border.
THis will center the bitmap on the screen, regardless of the screen size.)
(LET ((NEWBITMAP (BITMAPCREATE SCREENWIDTH SCREENHEIGHT 1))
(X (QUOTIENT (DIFFERENCE SCREENWIDTH (BITMAPWIDTH BITMAP))
2))
(Y (QUOTIENT (DIFFERENCE SCREENHEIGHT (BITMAPHEIGHT BITMAP))
2)))
(BITBLT BITMAP 1 1 NEWBITMAP X Y)
NEWBITMAP])
(BACKGROUND.REFLECT
[LAMBDA (BITMAP) (* hts: " 2-Apr-86 12:03")
(* * Centers BITMAP on a screen-sized bitmap and tiles the remaining space with reflections of BITMAP)
(LET* ((WIDTH (BITMAPWIDTH BITMAP))
(HEIGHT (BITMAPHEIGHT BITMAP))
(MAXWIDTH (TIMES 3 WIDTH))
(MAXHEIGHT (TIMES 2 HEIGHT))
(TOO.SMALL (OR (GREATERP SCREENWIDTH MAXWIDTH)
(GREATERP SCREENHEIGHT MAXHEIGHT)))
(NEWBITMAP (BITMAPCREATE (if TOO.SMALL
then MAXWIDTH
else SCREENWIDTH)
(if TOO.SMALL
then MAXHEIGHT
else SCREENHEIGHT)
1))
(X (IQUOTIENT (DIFFERENCE (BITMAPWIDTH NEWBITMAP)
WIDTH)
2))
(Y (if (GREATERP HEIGHT (BITMAPHEIGHT NEWBITMAP))
then (IQUOTIENT (DIFFERENCE (BITMAPHEIGHT NEWBITMAP)
HEIGHT)
2)
else 0)))
(* * Stick original bitmap in middle)
(BITBLT BITMAP NIL NIL NEWBITMAP X Y)
(if (OR (GREATERP SCREENWIDTH WIDTH)
(GREATERP SCREENHEIGHT HEIGHT))
then
(* * Build reflections)
(LET ((HORIZ (BITMAPCREATE WIDTH HEIGHT 1))
(VERT (BITMAPCREATE WIDTH HEIGHT 1))
(HORIZ.VERT (BITMAPCREATE WIDTH HEIGHT 1)))
(for I from 0 to (SUB1 WIDTH) do (BITBLT BITMAP I 0 HORIZ
(DIFFERENCE
(SUB1 WIDTH)
I)
0 1 HEIGHT))
(for I from 0 to (SUB1 HEIGHT)
do (BITBLT BITMAP 0 I VERT 0 (DIFFERENCE (SUB1 HEIGHT)
I)
WIDTH 1))
(for I from 0 to (SUB1 HEIGHT)
do (BITBLT HORIZ 0 I HORIZ.VERT 0 (DIFFERENCE (SUB1 HEIGHT)
I)
WIDTH 1))
(* * Upper left hand corner)
(BITBLT HORIZ.VERT NIL NIL NEWBITMAP (DIFFERENCE X WIDTH)
(PLUS Y HEIGHT))
(* * Above, center)
(BITBLT VERT NIL NIL NEWBITMAP X (PLUS Y HEIGHT))
(* * Upper right hand corner)
(BITBLT HORIZ.VERT NIL NIL NEWBITMAP (PLUS X WIDTH)
(PLUS Y HEIGHT))
(* * left)
(BITBLT HORIZ NIL NIL NEWBITMAP (DIFFERENCE X WIDTH)
Y)
(* * Right)
(BITBLT HORIZ NIL NIL NEWBITMAP (PLUS X WIDTH)
Y)
(* * If resulting reflected bitmap is still too small, recurse till it gets as big as the screen.)
(if TOO.SMALL
then (BACKGROUND.REFLECT NEWBITMAP)
else NEWBITMAP))
else NEWBITMAP])
(BACKGROUND.TILE
[LAMBDA (BITMAP) (* hts: " 1-Apr-86 18:13")
(bind (NEWBITMAP ← (BITMAPCREATE SCREENWIDTH SCREENHEIGHT 1)) for LEFT
from (BACKGROUND.LESS SCREENWIDTH (BITMAPWIDTH BITMAP)) by (BITMAPWIDTH BITMAP)
to SCREENWIDTH do (for BOTTOM from (if (GREATERP (BITMAPHEIGHT BITMAP)
SCREENHEIGHT)
then (BACKGROUND.LESS SCREENHEIGHT
(BITMAPHEIGHT
BITMAP))
else 0)
by (BITMAPHEIGHT BITMAP) to SCREENHEIGHT
do (BITBLT BITMAP NIL NIL NEWBITMAP LEFT BOTTOM))
finally (RETURN NEWBITMAP])
(BACKGROUND.LESS
[LAMBDA (BOXSIZE IMAGESIZE) (* hts: " 1-Apr-86 15:36")
(* * Tells where you have to start drawing to end up with a centered, tiled image)
(bind START first (SETQ START (ADD1 (QUOTIENT (DIFFERENCE BOXSIZE IMAGESIZE)
2)))
until (LEQ START 1) do (add START (MINUS IMAGESIZE)) finally (RETURN START])
)
(RPAQ? BACKGROUNDS NIL)
(RPAQ? BACKGROUND.MODE (QUOTE CENTER))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS BACKGROUNDS BackgroundMenuCommands LISPUSERSDIRECTORIES BACKGROUND.MODE)
)
(ADDTOVAR GAINSPACEFORMS ((LISTP BACKGROUNDS)
"Delete saved background bitmaps"
(SETQ BACKGROUNDS NIL)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA BACKGROUND.MODE)
)
(PUTPROPS BACKGROUNDIMAGES COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1453 8186 (BACKGROUND.SETUP 1463 . 2799) (BACKGROUND.FILES 2801 . 4164) (
BACKGROUND.FILE 4166 . 5187) (BACKGROUND.FETCH 5189 . 7131) (BACKGROUND.SHORTNAME 7133 . 7708) (
BACKGROUND.MODE 7710 . 8184)) (8187 12822 (BACKGROUND.CENTER 8197 . 8823) (BACKGROUND.REFLECT 8825 .
11645) (BACKGROUND.TILE 11647 . 12373) (BACKGROUND.LESS 12375 . 12820)))))
STOP