(FILECREATED "18-Mar-86 14:33:10" {PHYLUM}<FOSTER>LISP>STARBG.;4 20541
changes to: (VARS noReverseVideo STARBGParameters)
(FNS SuperCluster Cosmos)
previous date: "27-Feb-86 18:24:14" {PHYLUM}<FOSTER>LISP>STARBG.;3)
(* Copyright (c) 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT STARBGCOMS)
(RPAQQ STARBGCOMS [(VARS BM3 BM5 nova (eventPause 0)
(changeStars NIL)
noReverseVideo saucer darkSaucer saucerMask supernova STARBGParameters
trekNotes (starShade WHITESHADE)
(voidShade BLACKSHADE))
(FNS Between BlackHole Catastrophe ChanceIn CloseFollower Constellation Cosmos InvertBM
DefaultIfNeeded Enterprise FillWithStars OneChanceIn GlobalStarDefaultIfNeeded
LowerBound OpenFollower PlusOrMinus SaucerOn SaucerOff STARBG StarCluster SuperCluster
SomethingCosmic StarFollowCursor StarryWindow Stomp TimePasses UFO UpperBound)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML DefaultIfNeeded)
(LAMA)))
(P (OR (BOUNDP (QUOTE cursorFollower))
(SETQ cursorFollower (ICONW saucer saucerMask (CREATEPOSITION 0 0)
T)))
(if (BOUNDP (QUOTE IDLE.FUNCTIONS))
then
(PUSH IDLE.FUNCTIONS (QUOTE ("Cosmos" (QUOTE Cosmos)
"Go where no one has gone before... "])
(RPAQ BM3 (READBITMAP))
(3 3
"J@@@"
"@@@@"
"J@@@")
(RPAQ BM5 (READBITMAP))
(5 5
"MH@@"
"HH@@"
"@@@@"
"HH@@"
"MH@@")
(RPAQ nova (READBITMAP))
(9 9
"OGH@"
"OGH@"
"NCH@"
"LAH@"
"@@@@"
"LAH@"
"NCH@"
"OGH@"
"OGH@")
(RPAQQ eventPause 0)
(RPAQQ changeStars NIL)
(RPAQQ noReverseVideo NIL)
(RPAQ saucer (READBITMAP))
(24 16
"@@@@@@@@"
"C@@@@L@@"
"C@CL@L@@"
"@HDBA@@@"
"@DHAB@@@"
"@C@@L@@@"
"@OG@O@@@"
"CBE@DL@@"
"DBG@DB@@"
"HB@@DA@@"
"LAHAHC@@"
"K@GN@O@@"
"FN@@GJ@@"
"CKOOJL@@"
"@NJJO@@@"
"@AOOH@@@")
(RPAQ darkSaucer (READBITMAP))
(24 16
"A@@@@D@@"
"D@@@A@@@"
"@H@@@B@@"
"B@CL@H@@"
"@@GN@@@@"
"@@OO@@@@"
"@@HO@@@@"
"@MJOK@@@"
"CMHOKL@@"
"GMOOKN@@"
"CNGNGL@@"
"DOHAO@@@"
"AAOOHD@@"
"@D@@E@@@"
"@AEE@@@@"
"@@@@@@@@")
(RPAQ saucerMask (READBITMAP))
(24 16
"EH@@AF@@"
"G@@@AL@@"
"CHCL@N@@"
"FHGNAJ@@"
"@DOOB@@@"
"@COOL@@@"
"@OOOO@@@"
"COOOOL@@"
"GOOOON@@"
"OOOOOO@@"
"OOOOOO@@"
"OOOOOO@@"
"GOOOON@@"
"COOOOL@@"
"@OOOO@@@"
"@AOOH@@@")
(RPAQ supernova (READBITMAP))
(13 13
"OMOH"
"OMOH"
"OHOH"
"N@CH"
"N@CH"
"L@AH"
"@@@@"
"L@AH"
"N@CH"
"N@CH"
"OHOH"
"OMOH"
"OMOH")
(RPAQQ STARBGParameters (SBM BM1 BM2 BM3 BM4 BM5 nova supernova stars1 stars2 stars3 stars4 stars5
changeStars eventPause clusters clusterRadius constellations
starsInCluster superClusters superClusterRadius interiorClusters
starsInterior))
(RPAQQ trekNotes (<A+ D/ G+ F# E/ D/ D@/ C))
(RPAQ starShade WHITESHADE)
(RPAQ voidShade BLACKSHADE)
(DEFINEQ
(Between
[LAMBDA (pair) (* gsf: "19-Apr-85 10:33")
(* * picks an integer between limits given in the pair)
(RAND (LowerBound pair)
(UpperBound pair])
(BlackHole
[LAMBDA (win x y radius) (* gsf "21-Nov-85 15:53")
(OR x (SETQ x (RAND 0 SCREENWIDTH)))
(OR y (SETQ y (RAND 0 SCREENHEIGHT)))
(OR radius (SETQ radius (RAND 5 300)))
(FILLCIRCLE x y radius voidShade win)
(if (ZEROP (RAND 0 2))
then (FILLCIRCLE x y (RAND 2 5)
starShade win])
(Catastrophe
[LAMBDA (win) (* gsf: "13-Aug-85 15:47")
(LET ((extent (RAND 10 200))
(cx (RAND 0 SCREENWIDTH))
(cy (RAND 0 SCREENHEIGHT)))
(for i from 1 to extent do (Stomp win 50 (IPLUS cx (PlusOrMinus (RAND 0 extent)))
(IPLUS cy (PlusOrMinus (RAND 0 extent])
(ChanceIn
[LAMBDA (n) (* gsf: "23-Oct-85 14:49")
(ZEROP (RAND 0 (IDIFFERENCE n 1])
(CloseFollower
[LAMBDA NIL (* gsf: "28-Jun-85 11:14")
(CLOSEW cursorFollower])
(Constellation
[LAMBDA (bitmap cx cy stars) (* gsf: "12-Nov-85 13:09")
(OR cx (SETQ cx (RAND 0 SCREENWIDTH)))
(OR cy (SETQ cy (RAND 0 SCREENHEIGHT)))
(LET ((halfwidth (RAND 25 100))
(halfheight (RAND 25 100))
BM NEXT)
[OR stars (SETQ stars (RAND 4 (IQUOTIENT (MIN halfwidth halfheight)
3]
(for i from 1 to stars
do (SETQ BM (COND
((ILESSP (SETQ NEXT (RAND 0 100))
40)
BM3)
((ILESSP NEXT 60)
BM4)
((ILESSP NEXT 96)
BM5)
(T nova)))
(BITBLT BM 0 0 bitmap (IPLUS cx (PlusOrMinus (RAND 0 halfwidth)))
(IPLUS cy (PlusOrMinus (RAND 0 halfheight])
(Cosmos
[LAMBDA (starWindow) (* gsf "18-Mar-86 14:30")
(OR starWindow (SETQ starWindow (CREATEW WHOLESCREEN NIL 0)))
(if (AND (BOUNDP (QUOTE \IDLING))
\IDLING)
then (RESETLST (RESETSAVE voidShade WHITESHADE)
(RESETSAVE starShade BLACKSHADE)
(DSPFILL NIL voidShade (QUOTE REPLACE)
starWindow)
(GlobalStarDefaultIfNeeded)
(RESETSAVE BM1 (InvertBM BM1))
(RESETSAVE BM2 (InvertBM BM2))
(RESETSAVE BM3 (InvertBM BM3))
(RESETSAVE BM4 (InvertBM BM4))
(RESETSAVE BM5 (InvertBM BM5))
(RESETSAVE cursorFollower (ICONW darkSaucer saucerMask
(CREATEPOSITION 0 0)
T))
(RESETSAVE nova (InvertBM nova))
(RESETSAVE supernova (InvertBM supernova))
(RESETSAVE NIL (LIST [FUNCTION (LAMBDA (starWindow)
(if changeStars
then (BITBLT (InvertBM
starWindow
(QUOTE inPlace))
0 0 SBM)
(CLOSEW starWindow)
(CHANGEBACKGROUND SBM)
(CLOSEW cursorFollower]
starWindow))
(while T
do (SomethingCosmic starWindow)
(BLOCK eventPause)))
else (DSPFILL NIL voidShade (QUOTE REPLACE)
starWindow)
(GlobalStarDefaultIfNeeded)
(while T
do (SomethingCosmic starWindow)
(BLOCK))
(CLOSEW starWindow])
(InvertBM
[LAMBDA (bm inPlace?) (* gsf " 2-Jan-86 14:32")
(LET [(bitmap (if inPlace?
then bm
else (BITMAPCOPY bm]
(BITBLT bm NIL NIL bitmap NIL NIL NIL NIL (QUOTE INVERT)
(QUOTE REPLACE))
bitmap])
(DefaultIfNeeded
[NLAMBDA (var default) (* gsf: "19-Apr-85 10:43")
(* * default if no value already)
(AND (NOT (BOUNDP var))
(SET var default])
(Enterprise
[LAMBDA NIL (* edited: " 5-Apr-85 11:54")
(PLAYTUNE (PLAY.NOTES trekNotes])
(FillWithStars
[LAMBDA (bitmap) (* gsf "21-Nov-85 16:40")
(* * Fill a bitmap with stars and return it -- defaults to a screen sized bitmap)
(LET (width height)
(OR bitmap (SETQ bitmap (BITMAPCREATE 1024 808)))
(SETQ width (BITMAPWIDTH bitmap))
(SETQ height (if (WINDOWP bitmap)
then (WINDOWPROP bitmap (QUOTE HEIGHT))
else (BITMAPHEIGHT bitmap)))
(BITBLT bitmap 0 0 bitmap 0 0 width height (QUOTE INVERT)
(QUOTE PAINT))
(GlobalStarDefaultIfNeeded)
(for x from 1 to (Between stars1) do (BITMAPBIT bitmap (RAND 0 width)
(RAND 0 height)
(if (EQUAL voidShade BLACKSHADE)
then 0
else 1)))
(for x from 1 to (Between stars2) do (BITBLT BM2 0 0 bitmap (RAND 0 width)
(RAND 0 height)))
(for x from 1 to (Between stars3) do (BITBLT BM3 0 0 bitmap (RAND 0 width)
(RAND 0 height)))
(for x from 1 to (Between stars4) do (BITBLT BM4 0 0 bitmap (RAND 0 width)
(RAND 0 height)))
(for x from 1 to (Between stars5) do (BITBLT BM5 0 0 bitmap (RAND 0 width)
(RAND 0 height)))
(if (ChanceIn 5)
then (BITBLT nova 0 0 bitmap (RAND 0 width)
(RAND 0 height)))
(if (ChanceIn 100)
then (BITBLT supernova 0 0 bitmap (RAND 0 width)
(RAND 0 height)))
(for x from 1 to (Between constellations) do (Constellation bitmap))
(for x from 1 to (Between clusters) do (StarCluster (Between clusterRadius)
(RAND 0 width)
(RAND 0 height)
NIL bitmap))
(for x from 1 to (Between superClusters) do (SuperCluster (Between superClusterRadius)
(RAND 0 width)
(RAND 0 height)
(Between interiorClusters)
NIL bitmap))
bitmap])
(OneChanceIn
[LAMBDA (n) (* gsf: "23-Oct-85 15:04")
(ChanceIn n])
(GlobalStarDefaultIfNeeded
[LAMBDA NIL (* gsf: "12-Nov-85 13:32")
(OR (AND (BOUNDP (QUOTE BM1))
(BITMAPP BM1))
(SETQ BM1 (BITMAPCREATE 1 1)))
(OR (AND (BOUNDP (QUOTE BM2))
(BITMAPP BM2))
(SETQ BM2 (BITMAPCREATE 2 2)))
(OR (AND (BOUNDP (QUOTE BM4))
(BITMAPP BM4))
(SETQ BM4 (BITMAPCREATE 3 3)))
(RANDSET T)
(DefaultIfNeeded stars1 (500 . 3000))
(DefaultIfNeeded stars2 (40 . 400))
(DefaultIfNeeded stars3 (6 . 70))
(DefaultIfNeeded stars4 (1 . 3))
(DefaultIfNeeded stars5 (1 . 10))
(DefaultIfNeeded constellations (1 . 9))
(DefaultIfNeeded clusters (0 . 5))
(DefaultIfNeeded clusterRadius (5 . 15))
(DefaultIfNeeded starsInCluster (50 . 150))
(DefaultIfNeeded superClusters (0 . 1))
(DefaultIfNeeded superClusterRadius (8 . 20))
(DefaultIfNeeded interiorClusters (2 . 7))
(DefaultIfNeeded starsInterior (30 . 100])
(LowerBound
[LAMBDA (pair) (* edited: " 5-Apr-85 17:33")
(* * comment)
(CAR pair])
(OpenFollower
[LAMBDA NIL (* gsf: "11-Oct-85 15:15")
(OPENW cursorFollower)
(StarFollowCursor])
(PlusOrMinus
[LAMBDA (x) (* gsf: "25-Jun-84 18:02")
(ITIMES x (COND
((ZEROP (RAND 0 1))
-1)
(T 1])
(SaucerOn
[LAMBDA NIL (* gsf: "11-Oct-85 15:16")
(SETQ BACKGROUNDCURSORINFN (QUOTE OpenFollower))
(SETQ BACKGROUNDCURSORMOVEDFN (QUOTE StarFollowCursor))
(SETQ BACKGROUNDCURSOROUTFN (QUOTE CloseFollower))
(QUOTE TakeMeToYourLeader])
(SaucerOff
[LAMBDA NIL (* edited: " 7-Aug-85 18:12")
(SETQ BACKGROUNDCURSORINFN NIL)
(SETQ BACKGROUNDCURSORMOVEDFN NIL)
(SETQ BACKGROUNDCURSOROUTFN NIL)
(CLOSEW cursorFollower])
(STARBG
[LAMBDA (tuneFLG) (* gsf "11-Dec-85 15:09")
(SETQ SBM (FillWithStars (AND (BOUNDP (QUOTE SBM))
(BITMAPP SBM)
SBM)))
(AND tuneFLG (GETD (QUOTE PLAY.NOTES))
(Enterprise))
(if (NEQ tuneFLG (QUOTE NO))
then (CHANGEBACKGROUNDBORDER BLACKSHADE)
(SaucerOn)
(CHANGEBACKGROUND SBM])
(StarCluster
[LAMBDA (radius cx cy numStars bitmap) (* gsf "21-Nov-85 15:04")
[OR numStars (SETQ numStars (RAND 10 (EXPT (if (ChanceIn 20)
then radius
else (IDIFFERENCE radius 3))
2]
(LET ((dither (IQUOTIENT radius 2))
NEXT BM)
(for x from 1 to numStars
do (* pick a random star bitmap)
[SETQ BM (COND
((ILESSP (SETQ NEXT (RAND 0 100))
70)
BM1)
((ILESSP NEXT 83)
BM2)
((ILESSP NEXT 96)
BM3)
((ILESSP NEXT 100)
BM5)
(T (if (ChanceIn 1000)
then supernova
elseif (ChanceIn 50)
then nova
else BM4] (* put the star in a random constrained place)
(BITBLT BM 0 0 bitmap (IPLUS cx (PlusOrMinus (EXPT (RAND 1 (SUB1 radius))
2))
(RAND (MINUS dither)
dither))
(IPLUS cy (PlusOrMinus (EXPT (RAND 1 (SUB1 radius))
2))
(RAND (MINUS dither)
dither])
(SuperCluster
[LAMBDA (radius cx cy numberOfClusters maxStars bitmap) (* gsf "21-Nov-85 15:05")
(LET (rad)
(for x from 1 to numberOfClusters do (StarCluster (SETQ rad (RAND 5 radius))
(IPLUS (PlusOrMinus
(RAND 0 radius))
cx)
(IPLUS (PlusOrMinus
(RAND 0 radius))
cy)
(if maxStars
then (RAND 25 maxStars)
else (EXPT (SUB1 rad)
2))
bitmap])
(SomethingCosmic
[LAMBDA (bitmap) (* gsf "21-Nov-85 16:41")
(* * gsf: "14-Aug-85 16:24")
(LET [(x (RAND 0 1000))
(width (BITMAPWIDTH bitmap))
(height (if (WINDOWP bitmap)
then (WINDOWPROP bitmap (QUOTE HEIGHT))
else (BITMAPHEIGHT bitmap]
(if (LESSP x 600)
then (BITMAPBIT bitmap (RAND 0 width)
(RAND 0 height)
(if (EQUAL voidShade BLACKSHADE)
then 0
else 1))
[if (ZEROP (RAND 0 100))
then (for i from 1 to 100 do (BITMAPBIT bitmap (RAND 0 width)
(RAND 0 height)
(if (EQUAL voidShade BLACKSHADE)
then 0
else 1]
elseif (LESSP x 700)
then (BITBLT BM2 0 0 bitmap (RAND 0 width)
(RAND 0 height))
elseif (LESSP x 720)
then (BITBLT BM3 0 0 bitmap (RAND 0 width)
(RAND 0 height))
elseif (LESSP x 725)
then [LET ((bm BM4))
(if (ChanceIn 50)
then (if (ChanceIn 10)
then (SETQ bm supernova)
else (SETQ bm nova))
else (BITBLT bm 0 0 bitmap (RAND 0 width)
(RAND 0 height]
elseif (LESSP x 740)
then (BITBLT BM5 0 0 bitmap (RAND 0 width)
(RAND 0 height))
elseif (LESSP x 745)
then (Constellation bitmap)
elseif (LESSP x 747)
then (StarCluster (Between clusterRadius)
(RAND 0 width)
(RAND 0 height)
NIL bitmap)
elseif (LESSP x 748)
then (SuperCluster (Between superClusterRadius)
(RAND 0 width)
(RAND 0 height)
(Between interiorClusters)
NIL bitmap)
elseif (LESSP x 752)
then (SELECTQ (RAND 0 7)
[0 (if (BITMAPP bitmap)
then (Catastrophe bitmap)
else (if (ChanceIn 4)
then (for i from 1 to (RAND 2 5) do (BlackHole bitmap))
else (BlackHole bitmap]
((1 2 3 4)
(if (ChanceIn 3)
then (for i from 1 to (RAND 2 9) do (Catastrophe bitmap))
else (Catastrophe bitmap)))
(5 (if (BITMAPP bitmap)
then (Catastrophe bitmap)
else (UFO)))
[6 (for i from 1 to (RAND 2 9) do (SELECTQ (RAND 0 5)
((0 1 2)
(Catastrophe bitmap))
((3 4)
(if (BITMAPP bitmap)
then (Catastrophe bitmap)
else (BlackHole bitmap)))
(TimePasses bitmap]
(TimePasses bitmap))
else (Stomp bitmap])
(StarFollowCursor
[LAMBDA NIL (* gsf: "23-Oct-85 16:16")
(LET ((oldRegion (WINDOWPROP cursorFollower (QUOTE REGION)))
(x (DIFFERENCE LASTMOUSEX 25))
(y (DIFFERENCE LASTMOUSEY 17)))
(if (OR (NEQ (fetch LEFT of oldRegion)
x)
(NEQ (fetch BOTTOM of oldRegion)
y))
then (MOVEW cursorFollower x y])
(StarryWindow
[LAMBDA (win) (* gsf: " 9-Aug-85 10:57")
(RESETLST (RESETSAVE stars1 (CONS 10 1000))
(RESETSAVE stars1 (CONS 10 1000))
(RESETSAVE stars2 (CONS 10 500))
(RESETSAVE stars3 (CONS 10 200))
(RESETSAVE stars4 (CONS 1 3))
(RESETSAVE stars5 (CONS 1 5))
(RESETSAVE clusters (CONS 0 3))
(RESETSAVE starsInCluster (CONS 10 30))
(RESETSAVE superClusters (CONS 0 1))
(RESETSAVE starsInterior (CONS 10 50))
(OR win (SETQ win (CREATEW NIL NIL 0)))
(FillWithStars win])
(Stomp
[LAMBDA (win footprint x y) (* gsf "21-Nov-85 15:53")
(OR footprint (SETQ footprint 40))
[OR x (SETQ x (RAND (MINUS footprint)
(if (WINDOWP win)
then (WINDOWPROP win (QUOTE WIDTH))
else (BITMAPWIDTH win]
[OR y (SETQ y (RAND (MINUS footprint)
(if (WINDOWP win)
then (WINDOWPROP win (QUOTE HEIGHT))
else (BITMAPHEIGHT win]
(BITBLT NIL NIL NIL win x y (RAND 1 footprint)
(RAND 1 footprint)
(QUOTE TEXTURE)
(QUOTE REPLACE)
voidShade])
(TimePasses
[LAMBDA (win) (* gsf: "13-Aug-85 16:05")
(for i from 1 to (RAND 100 4000) do (Stomp win 30])
(UFO
[LAMBDA NIL (* gsf "14-Nov-85 10:33")
(LET ((x (RAND 0 SCREENWIDTH))
(y (RAND 0 SCREENHEIGHT))
(deltaX (RAND -7 7))
(deltaY (RAND -7 7)))
(MOVEW cursorFollower x y)
(OPENW cursorFollower)
[until (OR (LESSP x 0)
(LESSP y 0)
(GREATERP x SCREENWIDTH)
(GREATERP y SCREENHEIGHT))
do (MOVEW cursorFollower (SETQ x (IPLUS x deltaX))
(SETQ y (IPLUS y deltaY)))
(if (ZEROP (RAND 0 15))
then (SETQ deltaX (RAND -7 7)))
(if (ZEROP (RAND 0 15))
then (SETQ deltaY (RAND -7 7)))
(if (ZEROP (RAND 0 30))
then (BLOCK (RAND 10 1001]
(CLOSEW cursorFollower])
(UpperBound
[LAMBDA (pair) (* edited: " 5-Apr-85 17:34")
(* * comment)
(CDR pair])
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML DefaultIfNeeded)
(ADDTOVAR LAMA )
)
(OR (BOUNDP (QUOTE cursorFollower))
(SETQ cursorFollower (ICONW saucer saucerMask (CREATEPOSITION 0 0)
T)))
[if (BOUNDP (QUOTE IDLE.FUNCTIONS))
then
(PUSH IDLE.FUNCTIONS (QUOTE ("Cosmos" (QUOTE Cosmos)
"Go where no one has gone before... "]
(PUTPROPS STARBG COPYRIGHT ("Xerox Corporation" 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2841 20043 (Between 2851 . 3090) (BlackHole 3092 . 3509) (Catastrophe 3511 . 3909) (
ChanceIn 3911 . 4066) (CloseFollower 4068 . 4211) (Constellation 4213 . 5003) (Cosmos 5005 . 6603) (
InvertBM 6605 . 6913) (DefaultIfNeeded 6915 . 7143) (Enterprise 7145 . 7297) (FillWithStars 7299 .
9518) (OneChanceIn 9520 . 9650) (GlobalStarDefaultIfNeeded 9652 . 10751) (LowerBound 10753 . 10914) (
OpenFollower 10916 . 11084) (PlusOrMinus 11086 . 11277) (SaucerOn 11279 . 11612) (SaucerOff 11614 .
11880) (STARBG 11882 . 12321) (StarCluster 12323 . 13529) (SuperCluster 13531 . 14113) (
SomethingCosmic 14115 . 17033) (StarFollowCursor 17035 . 17484) (StarryWindow 17486 . 18189) (Stomp
18191 . 18851) (TimePasses 18853 . 19040) (UFO 19042 . 19878) (UpperBound 19880 . 20041)))))
STOP