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

(FILECREATED "24-Aug-2022 08:54:17" {DSK}<home>larry>medley>lispusers>STARBG.;2 16815  

      :CHANGES-TO (FNS Cosmos)

      :PREVIOUS-DATE "17-Aug-88 03:26:58" {DSK}<home>larry>medley>lispusers>STARBG.;1)


(* ; "
Copyright (c) 1984-1988 by Xerox Corporation.
")

(PRETTYCOMPRINT STARBGCOMS)

(RPAQQ STARBGCOMS
       [(INITVARS (eventPause 0)
               (changeStars NIL)
               (starShade WHITESHADE)
               (voidShade BLACKSHADE)
               (stars1 '(500 . 3000))
               (stars2 '(40 . 400))
               (stars3 '(6 . 70))
               (stars4 '(1 . 3))
               (stars5 '(1 . 10))
               (constellations '(1 . 9))
               (clusters '(0 . 5))
               (clusterRadius '(5 . 15))
               (starsInCluster '(50 . 150))
               (superClusters '(0 . 1))
               (superClusterRadius '(8 . 20))
               (interiorClusters '(2 . 7))
               (starsInterior '(30 . 100))
               (BM1 (SETQ BM1 (BITMAPCREATE 1 1)))
               (BM2 (BITMAPCREATE 2 2))
               (BM4 (BITMAPCREATE 3 3)))
        (BITMAPS BM3 BM5 nova)
        (VARS noReverseVideo saucer darkSaucer saucerMask supernova STARBGParameters trekNotes)
        (FNS Between BlackHole Catastrophe ChanceIn CloseFollower Constellation Cosmos InvertBM 
             FillWithStars Marble OneChanceIn LowerBound OpenFollower PlusOrMinus RandGrey SaucerOn 
             SaucerOff STARBG StarCluster SuperCluster SomethingCosmic StarFollowCursor StarryWindow
             Stomp TimePasses UFO UpperBound)
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA)))
        (P (RANDSET T)
           (OR (BOUNDP 'cursorFollower)
               (SETQ cursorFollower (ICONW saucer saucerMask (CREATEPOSITION 0 0)
                                           T)))
           (if (BOUNDP 'IDLE.FUNCTIONS)
               then
               (PUSH IDLE.FUNCTIONS '("Cosmos" 'Cosmos "Go where no one has gone before... "])

(RPAQ? eventPause 0)

(RPAQ? changeStars NIL)

(RPAQ? starShade WHITESHADE)

(RPAQ? voidShade BLACKSHADE)

(RPAQ? stars1 '(500 . 3000))

(RPAQ? stars2 '(40 . 400))

(RPAQ? stars3 '(6 . 70))

(RPAQ? stars4 '(1 . 3))

(RPAQ? stars5 '(1 . 10))

(RPAQ? constellations '(1 . 9))

(RPAQ? clusters '(0 . 5))

(RPAQ? clusterRadius '(5 . 15))

(RPAQ? starsInCluster '(50 . 150))

(RPAQ? superClusters '(0 . 1))

(RPAQ? superClusterRadius '(8 . 20))

(RPAQ? interiorClusters '(2 . 7))

(RPAQ? starsInterior '(30 . 100))

(RPAQ? BM1 (SETQ BM1 (BITMAPCREATE 1 1)))

(RPAQ? BM2 (BITMAPCREATE 2 2))

(RPAQ? BM4 (BITMAPCREATE 3 3))

(RPAQQ BM3 #*(3 3)J@@@@@@@J@@@)

(RPAQQ BM5 #*(5 5)MH@@HH@@@@@@HH@@MH@@)

(RPAQQ nova #*(9 9)OGH@OGH@NCH@LAH@@@@@LAH@NCH@OGH@OGH@)

(RPAQQ noReverseVideo NIL)

(RPAQQ saucer #*(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@@@
)

(RPAQQ darkSaucer #*(24 16)A@@@@D@@D@@@A@@@@H@@@B@@B@CL@H@@@@GN@@@@@@OO@@@@@@HO@@@@@MJOK@@@CMHOKL@@GMOOKN@@CNGNGL@@DOHAO@@@AAOOHD@@@D@@E@@@@AEE@@@@@@@@@@@@
)

(RPAQQ saucerMask #*(24 16)EH@@AF@@G@@@AL@@CHCL@N@@FHGNAJ@@@DOOB@@@@COOL@@@@OOOO@@@COOOOL@@GOOOON@@OOOOOO@@OOOOOO@@OOOOOO@@GOOOON@@COOOOL@@@OOOO@@@@AOOH@@@
)

(RPAQQ supernova #*(13 13)OMOHOMOHOHOHN@CHN@CHL@AH@@@@L@AHN@CHN@CHOHOHOMOHOMOH)

(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))
(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)                                     (* ; "Edited 24-Aug-2022 08:05 by larry")
                                                           (* ; "Edited 17-Aug-88 03:25 by EWEAVER")
    (OR starWindow (SETQ starWindow (CREATEW WHOLESCREEN NIL 0)))
    (if (VIDEOCOLOR)
        then (RESETLST
                 (RESETSAVE voidShade WHITESHADE)
                 (RESETSAVE starShade BLACKSHADE)
                 (DSPFILL NIL voidShade 'REPLACE starWindow)
                 (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 'inPlace)
                                                                  0 0 SBM)
                                                           (CLOSEW starWindow)
                                                           (CHANGEBACKGROUND SBM)
                                                           (CLOSEW cursorFollower]
                                      starWindow))
                 (DSPOPERATION 'REPLACE starWindow)
                 (while T do (SomethingCosmic starWindow)
                             (BLOCK eventPause)))
      else (DSPFILL NIL voidShade 'REPLACE starWindow)
           (DSPOPERATION 'REPLACE starWindow)
           (while T do (SomethingCosmic starWindow)
                       (BLOCK 100))
           (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))
)

(FillWithStars
(LAMBDA (bitmap) (* gsf "19-Jun-86 14:01") (* * 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)) (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))
)

(Marble
(LAMBDA (bm) (* gsf " 1-Apr-87 13:32") (RESETLST (RESETSAVE stars1 (QUOTE (100000 . 200000))) (RESETSAVE stars2 (QUOTE (400 . 2000))) (RESETSAVE stars3 (QUOTE (1000 . 4000))) (RESETSAVE stars4 (QUOTE (400 . 2000))) (RESETSAVE stars5 (QUOTE (200 . 400))) (RESETSAVE clusters (QUOTE (50 . 100))) (RESETSAVE clusterRadius (QUOTE (5 . 15))) (RESETSAVE starsInCluster (QUOTE (50 . 150))) (RESETSAVE superClusters (QUOTE (20 . 50))) (RESETSAVE superClusterRadius (QUOTE (8 . 20))) (RESETSAVE interiorClusters (QUOTE (2 . 7))) (RESETSAVE starsInterior (QUOTE (30 . 100))) (FillWithStars bm)))
)

(OneChanceIn
(LAMBDA (n) (* gsf%: "23-Oct-85 15:04") (ChanceIn n)))

(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)))))

(RandGrey
(LAMBDA (bitmap) (* gsf " 1-Apr-87 14:00") (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)) (for x from 1 to (RAND (IQUOTIENT (TIMES width height) 2) (TIMES width height)) do (BITMAPBIT bitmap (RAND 0 width) (RAND 0 height) 0)) bitmap))
)

(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 )

(ADDTOVAR LAMA )
)

(RANDSET T)

(OR (BOUNDP 'cursorFollower)
    (SETQ cursorFollower (ICONW saucer saucerMask (CREATEPOSITION 0 0)
                                T)))

[if (BOUNDP 'IDLE.FUNCTIONS)
    then (PUSH IDLE.FUNCTIONS '("Cosmos" 'Cosmos "Go where no one has gone before... "]
(PUTPROPS STARBG COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1987 1988))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (4087 16303 (Between 4097 . 4250) (BlackHole 4252 . 4539) (Catastrophe 4541 . 4807) (
ChanceIn 4809 . 4895) (CloseFollower 4897 . 4977) (Constellation 4979 . 5529) (Cosmos 5531 . 7588) (
InvertBM 7590 . 7791) (FillWithStars 7793 . 9243) (Marble 9245 . 9840) (OneChanceIn 9842 . 9909) (
LowerBound 9911 . 9995) (OpenFollower 9997 . 10094) (PlusOrMinus 10096 . 10198) (RandGrey 10200 . 
10679) (SaucerOn 10681 . 10916) (SaucerOff 10918 . 11098) (STARBG 11100 . 11384) (StarCluster 11386 . 
12132) (SuperCluster 12134 . 12475) (SomethingCosmic 12477 . 14332) (StarFollowCursor 14334 . 14631) (
StarryWindow 14633 . 15104) (Stomp 15106 . 15553) (TimePasses 15555 . 15662) (UFO 15664 . 16215) (
UpperBound 16217 . 16301)))))
STOP
