Thread View: comp.windows.news
1 messages
1 total messages
Started by Liam R. E. Quin
Sat, 29 Aug 1992 05:24
src: HexSweeper 1.66: game (for OpenWindows 3 only)
Author: Liam R. E. Quin
Date: Sat, 29 Aug 1992 05:24
Date: Sat, 29 Aug 1992 05:24
1778 lines
42286 bytes
42286 bytes
Here is HexSweeper 1.66. It's a lot faster than 1.0 at many things,
and somewhat more playable as a game.
HexSweeper is a game a bit like the VMS (or Microsoft Windows) minesweeper
game, except that instead of a rectangular grid there's a grid of hexagons.
Known problems:
* There's no high score yet, and no Properties window.
* Do not go directly from Texas Scale to Welsh Cottage Scale!
(perhaps the program should prevent this)
If you do get a problem, press L1 (STOP) if the mouse stops working, and
then either use pskill or pam to get rid of the Hex ps processes. I can
mail you an effective pskill if you don't have it.
Don't be discouraged by that warning - HexSweeper is fun to play with,
and it works in both colour and mono. It uses your Window colour, so if
you want, bring up props (Workspace menu->Properties) and change the colours!
Please tell me if you try HexSweeper.
Lee
lee@sq.com
#! /bin/sh
: To unbundle, sh this file
echo x - hexsweeper 1>&2
sed 's/^X//' >hexsweeper <<'@@@End of hexsweeper'
X#! /usr/openwin/bin/psh -i
X
X% $Id: hexsweeper,v 1.67 92/08/29 00:59:56 lee Exp $
X/MyName (HexSweeper 1.66) def
X
X/NeWS 3 0 findpackage beginpackage
X/TNTCore 3 0 findpackage beginpackage
X/TNT 3 0 findpackage beginpackage
X% /debug 1 0 findpackage beginpackage
X
Xstatusdict begin 1200 setjobtimeout end
X
Xtrue setpacking
X
X/MineDict 20 dict dup begin
X /SecondsSoFar 0 def
X /Counting false def
X /MineCount 0 def
X /MineRows -1 def
X /MineCols -1 def
Xend def
X
X/HexTimerProcess {
X currentprocess /ProcessName (HexTimer) put
X MineDict begin
X [3 0] sleep
X {
X pause [1 0] sleep
X Counting
X {
X createevent dup begin
X /Name /HexTimerEvent def
X /Action (HexTimerEvent) def
X end
X sendevent
X } if
X pause
X } loop
X} fork def
X
X/sqrt3 3 sqrt def
X
X/Hex3DDict 12 dict def
X/Hex3DInnerDict 12 dict def
X
X/SetHexSizeFromFlat {
X /HexHWidth exch def
X /HexDWidth HexHWidth 2 div def
X /HexDHeight HexHWidth sqrt3 mul 2 div def
X /HexHDelta HexDWidth HexHWidth add def
X /HexWidth HexDWidth 2 mul HexHWidth add def
X /HexHeight HexDHeight 2 mul def
X /HexDepth HexHWidth 7 div cvi dup 0 eq { pop 1 } if def
X MakeGlyphs
X} def
X
X/HexFont { /GillSans } def
X/HexBoldFont { /Rockwell-Bold } def
X
X% TNT display items for glyphs:
X/MakeGlyphs {
X /BombGlyph [ (\154) ] def
X /SetBombFont { /ZapfDingbats findfont HexHWidth scalefont setfont } def
X /WrongMarkGlyph [
X (\067)
X /ZapfDingbats findfont HexWidth scalefont % pretty huge...
X 1 0 0 rgbcolor
X ] def
X /MarkGlyph [(\076) /ZapfDingbats findfont HexWidth scalefont ] def
X
X framebuffer /Color get {
X /0Glyph ( ) def %% actually never used
X /1Glyph [(1) HexFont findfont HexWidth 1.5 div scalefont
X 0 0 1 rgbcolor ] def
X /2Glyph [(2) HexFont findfont HexWidth scalefont
X 0 1 0 rgbcolor ] def
X /3Glyph [(3) HexFont findfont HexWidth scalefont
X 0 1 1 rgbcolor ] def
X /4Glyph [(4) HexBoldFont findfont HexWidth scalefont
X 1 0 1 rgbcolor ] def
X /5Glyph [(5) HexBoldFont findfont HexWidth scalefont
X 1 .9 0 rgbcolor ] def
X /6Glyph [(6) HexBoldFont findfont HexWidth 1.5 mul scalefont
X 0.8 0 0 rgbcolor ] def
X } {
X /0Glyph ( ) def
X /Black 0 0 0 rgbcolor def
X /1Glyph [(1) HexFont findfont HexWidth 1.5 div scalefont Black ] def
X /2Glyph [(2) HexFont findfont HexWidth scalefont Black ] def
X /3Glyph [(3) HexFont findfont HexWidth scalefont Black ] def
X /4Glyph [(4) HexBoldFont findfont HexWidth scalefont Black ] def
X /5Glyph [(5) HexBoldFont findfont HexWidth scalefont Black ] def
X /6Glyph [(6) HexBoldFont findfont HexWidth 1.5 mul scalefont Black ] def
X } ifelse
X
X /GlyphArray [ 0Glyph 1Glyph 2Glyph 3Glyph 4Glyph 5Glyph 6Glyph ] def
X} def
X
X%%%% Default hex size
X
X25 SetHexSizeFromFlat
X
X/FindHexWestPoint { % x y FindHexWestPoint -> x y of p0
X 12 dict begin
X % transform coordinates so the centre of hex 0,0 is at 0,0:
X /y exch HexDHeight sub def
X /x exch HexWidth 2 div sub def
X
X % find a 60 degree line to the left of (x, y)
X % that intersects the x axis at a multiple of HWidth units
X
X % +
X % /|
X % / | Angle t is 60 degrees, so
X % / | y x - x1 = y/sqrt3
X % /t) |
X % +----+ . . .+
X % x1 x x2 [see below]
X
X % (calculate x1 and round down to a multiple of HexHWidth)
X /x1 x y sqrt3 div sub HexHWidth div dup 0 lt {
X /a exch def
X a cvi dup a eq not {
X 1 sub
X } if
X } {
X cvi
X } ifelse def
X
X % Now we do the same in the other direction:
X /x2 y sqrt3 div x add HexHWidth div dup 0 lt {
X /a exch def
X a cvi dup a eq not {
X 1 sub
X } if
X } {
X cvi
X } ifelse def
X
X % intersect the two lines:
X /x3 x2 x1 add 2 div HexHWidth mul def
X /y3 x2 HexHWidth mul x3 sub sqrt3 mul def
X
X % A debugging triangle:
X % 2 setlinewidth 0 setgray x1 HexHWidth mul 0 moveto x3 y3 lineto stroke
X % 1 setgray x2 HexHWidth mul 0 moveto x3 y3 lineto stroke
X % x 0 moveto x y lineto stroke
X
X % Now we check that the intersection will be a West point:
X x1 x2 add 3 mod 3 add 3 mod {
X 0 { % found a centre
X /x1 x1 1 sub def
X /x2 x2 1 sub def
X }
X 1 {
X % it's perfect!
X }
X 2 {
X % found a top left or bottom left corner.
X % intersect the two lines:
X y3 y lt {
X /x1 x1 1 sub def
X } {
X /x2 x2 1 sub def
X } ifelse
X }
X } case
X
X /x3 x2 x1 add 2 div HexHWidth mul def
X /y3 x2 HexHWidth mul x3 sub sqrt3 mul def
X
X % Another debugging triangle:
X % 0 setlinewidth 0 setgray x1 HexHWidth mul 0 moveto x3 y3 lineto stroke
X % 1 setgray x2 HexHWidth mul 0 moveto x3 y3 lineto stroke
X
X x3 HexWidth 2 div add
X y3 HexDHeight add
X end
X} def
X
X/MakeHex {
X /p0y exch def
X /p0x exch def
X /p1x HexDWidth p0x add def /p1y HexDHeight p0y add def
X /p2x HexHWidth p1x add def /p2y p1y def
X /p3x HexDWidth p2x add def /p3y p0y def
X /p4x p2x def /p4y p0y HexDHeight sub def
X /p5x p1x def /p5y p4y def
X} def
X
X/Draw2DHexAt {
X Hex3DDict begin
X % x y of Western (leftmost) point
X
X canvas1 setcanvas
X 2 copy moveto % p0
X /p0y exch def
X /p0x exch def
X
X HexDWidth HexDHeight rlineto % p1
X HexHWidth 0 rlineto % p2
X HexDWidth HexDHeight neg rlineto % p3
X p0x HexHDelta add p0y HexDHeight sub lineto % p4
X p0x HexDWidth add p0y HexDHeight sub lineto
X gsave
X clip
X
X pause pause pause
X clippath BG2 setcolor fill
X grestore
X % pause pause pause
X % gsave
X % 1 setlinewidth FG setcolor stroke
X % pause pause pause
X % grestore
X end
X} def
X
X/OldDraw2DHexAt {
X Hex3DDict begin
X MakeHex
X 0 setlinewidth
X newpath p0x p0y moveto
X p1x p1y lineto
X p2x p2y lineto
X p3x p3y lineto
X p4x p4y lineto
X p5x p5y lineto
X gsave
X BG2 setcolor fill
X grestore
X gsave
X 1.2 setlinewidth FG setcolor closepath stroke
X grestore
X% gsave %
X% p0x p0y
X% SetBombFont exch HexWidth 2 div add exch % x y of centre of hex
X% FG setcolor (X) DisplayItemSize % x y w h
X% 2 div neg exch 2 div neg exch xyadd moveto (X) DisplayItemPaint
X% grestore
X end
X} def
X
X/Draw3DHexAt {
X Hex3DDict begin
X MakeHex
X
X 0 setlinewidth
X newpath p0x p0y moveto
X p1x p1y lineto
X p2x p2y lineto
X p3x p3y lineto
X p4x p4y lineto
X p5x p5y lineto
X clip
X clippath BG setcolor fill
X
X HexDepth 2 mul setlinewidth
X
X p0x p0y moveto
X p1x p1y lineto
X p2x p2y lineto
X BG0 setcolor stroke
X
X p2x p2y moveto
X p3x p3y lineto
X p5x p5y moveto
X p0x p0y lineto
X BG2 setcolor stroke
X
X p3x p3y moveto
X p4x p4y lineto
X p5x p5y lineto
X BG3 setcolor stroke
X initclip
X HexHWidth 30 gt {
X gsave
X 0 setlinewidth
X FG setcolor stroke
X grestore
X } if
X end
X} def
X
X
X/ClearMines { % rows cols ClearMines -
X /MineBoard growabledict def
X /PlacesBeen growabledict def
X % Rows Cols
X mul dup array % n array
X MineDict exch % n Dict array
X /NearbyMines exch put
X % n
X 1 sub -1 0 {
X MineDict /NearbyMines get exch 0 put
X } for
X} def
X
X/RecomputeNeighbours {
X % (Computing neighbours for % by %)[MineDict /MineRows get 1 sub MineDict /MineCols get 1 sub]sprintf ==
X /NeighboursDict growabledict def
X
X 8 dict begin
X gsave
X canvas1 setcanvas
X bbox /ht exch def /wd exch def pop pop
X
X /Rockwell-Bold findfont 70 scalefont setfont
X /s (HEXSWEEPER!) def
X s DisplayItemSize 2 div neg exch 2 div neg exch
X wd 2 div ht 2 div xyadd moveto
X s DisplayItemPaint
X
X /MaxCol MineDict /MineCols get 1 sub def
X /MaxRow MineDict /MineRows get 1 sub def
X
X % Do edges, but not the corners:
X 1 1 MaxRow 1 sub {
X /Row exch def
X % Left edge:
X NeighboursDict 0 Row (%-%) sprintf
X [ null [ Row 1 add 0] [Row 1]
X [Row 1 sub 1] [ Row 1 sub 0] null ] put
X % Right edge:
X NeighboursDict MaxCol Row (%-%) sprintf
X MaxCol 2 mod 0 eq {
X % even
X [ [Row MaxCol 1 sub] [Row 1 add MaxCol] null
X null [Row 1 sub MaxCol] [Row 1 sub MaxCol 1 sub]
X ]
X } {
X % odd
X [ [Row 1 add MaxCol 1 sub] [Row 1 add MaxCol] null
X null [Row 1 sub MaxCol] [Row MaxCol 1 sub]
X ]
X } ifelse put
X
X % now the intermediate columns:
X 1 1 MaxCol 1 sub {
X /Col exch def
X NeighboursDict
X Col Row (%-%) sprintf
X Col 2 mod 0 eq {
X [
X [Row Col 1 sub] [Row 1 add Col]
X [Row Col 1 add] [Row 1 sub Col 1 add]
X [Row 1 sub Col] [Row 1 sub Col 1 sub]
X ]
X } {
X [
X [Row 1 add Col 1 sub] [Row 1 add Col]
X [Row 1 add Col 1 add] [Row Col 1 add]
X [Row 1 sub Col] [Row Col 1 sub]
X ]
X } ifelse
X put
X } for
X
X pause
X random 0.2 ge {
X random Rows 1 add mul cvi
X random Cols 1 add mul cvi
X CoordsToPoint Draw3DHexAt
X } if
X } for
X
X % now do the corners and top and bottom rows:
X 0 1 MaxCol {
X /Col exch def
X NeighboursDict dup
X Col 0 (%-%) sprintf
X 0 Col FindNeighbours
X put
X Col MaxRow (%-%) sprintf
X MaxRow Col FindNeighbours
X put
X } for
X
X grestore
X end
X} def
X
X/GetNearbyMines { % Row Col GetNearbyMines n
X 6 dict begin
X /Col exch def
X /Row exch def
X /Rows MineDict /MineRows get def
X /Cols MineDict /MineCols get def
X Col Cols ge Row Rows ge or
X Col 0 lt Row 0 lt or
X or {
X (Tried to look at Row % Col %, max is Row % Col %)
X [Row Col Rows Cols] sprintf ==
X 0
X } {
X MineDict /NearbyMines get % array
X Row Col Rows mul add get % int or null
X } ifelse
X end
X} def
X
X/AddNearbyMine { % Row Col -
X 4 dict begin
X /Col exch def
X /Row exch def
X /Rows MineDict /MineRows get def
X /Cols MineDict /MineCols get def
X MineDict /NearbyMines get dup % array
X Row Col Rows mul add get % array int or null
X dup null eq {
X pop 1
X } {
X 1 add
X } ifelse
X % Array value
X Row Col Rows mul add exch % Array index value
X put % int or null
X end
X} def
X
X/GetNeighbours {
X exch (%-%) sprintf dup % name name
X NeighboursDict exch known { % name
X NeighboursDict exch get
X } {
X pop [null null null null null null]
X } ifelse
X} def
X
X/CheckInRange { % x y -> bool
X 4 dict begin
X FindHexWestPoint % x' y'
X PointToCoords
X /Col exch def
X /Row exch def
X
X /Rows MineDict /MineRows get def
X /Cols MineDict /MineCols get def
X
X Col Cols ge Row Rows ge or Col 0 lt Row 0 lt or
X or % true if out or range
X not % true iff in range
X end
X} def
X
X/PointToCoords { % x y PointToCoords Row Col
X % Note: the point must be the Westernmost corner of the Hex
X exch % y x
X HexHDelta div cvi % y y Col
X dup 2 mod 1 eq { % y Col
X exch % Col y
X HexDWidth sub
X } {
X exch % Col y
X } ifelse % Col y
X HexDWidth sub
X HexHeight div
X dup 0 lt { 1 sub } if
X cvi
X exch
X} def
X
X/DoAutoWalk { % Row Col DoAutoWalk -
X %%
X %% Called when we find that we have landed on a hexagon with no
X %% nearby mines (GetNearbyMines returned 0). We have already been
X %% drawn flat at this point.
X %%
X %% We flatten each of the neighbours. If any neighbour has
X %% no nearby mines, we repeat the process for that neighbour.
X %%
X /busy /setcursor window1 send
X 7 dict begin
X /OnStack growabledict def
X
X mark
X 3 1 roll % mark Row Col
X
X {
X
X dup mark eq { pop exit } if
X
X % mark Row Col (and maybe Row Col Row Col...)
X 2 copy (%-%) sprintf /NAME exch def
X PlacesBeen NAME true put
X
X% gsave
X% 6 setrasteropcode
X% SetBombFont
X% 2 copy CoordsToPoint % x y
X% exch HexWidth 2 div add exch % x y of centre of hex
X% (X) DisplayItemSize % x y w h
X% 2 div neg exch 2 div neg exch xyadd moveto (X) DisplayItemPaint
X% grestore
X
X % Row Col
X /C exch def
X /R exch def
X R C GetNeighbours % Array
X 0.5 random gt { arrayreverse } if
X {
X dup null eq {
X pop
X } {
X aload pop
X % Try to reject as many neighbours as possible as soon as
X % possible...
X
X % Row Col
X 2 copy (%-%) sprintf dup dup
X % Row Col name name name
X OnStack exch known % Row Col name name bool
X exch PlacesBeen exch known % Row Col name bool bool
X or {
X %% Either already decided to look here, or already
X %% visited here...
X % Row Col name
X pop pop pop
X } {
X % Row Col Name
X /N exch def
X
X % Row Col
X 2 copy GetNearbyMines % Row Col n
X /n exch def
X 2 copy CoordsToPoint % Row Col x y
X
X n 0 eq {
X % Row Col x y
X Draw2DHexAt
X % Row Col
X /Needed true def
X
X % If there is a neighbour of this hex that
X % has zero nearby mines and is on the stack,
X % and is not (R, C), we don't need to
X % put _this_ one on the stack
X 2 copy GetNeighbours {
X dup null eq {
X pop
X } {
X aload pop % row col
X % check it's not the starting hex:
X 2 copy C ne exch R ne or
X % row col bool
X 3 1 roll (%-%) sprintf % bool name
X OnStack exch known % bool bool
X and {
X /Needed false def
X exit
X } if
X } ifelse
X pause
X } forall
X Needed {
X OnStack N true put
X } {
X pop pop
X } ifelse
X } {
X n DrawHexGlyphAt
X PlacesBeen N true put
X pop pop
X } ifelse
X } ifelse
X } ifelse
X } forall
X
X OnStack NAME undef
X pause pause pause
X
X } loop
X end
X /basic /setcursor window1 send
X} def
X
X/FlattenHex { % x y n FlattenHex -
X 3 1 roll % n x y
X 2 copy Draw2DHexAt % -
X % n x y
X 3 -1 roll dup 0 eq {
X pop pop pop
X } {
X % x y n
X DrawHexGlyphAt
X } ifelse
X} def
X
X/DrawHexGlyphAt { % x y n -
X GlyphArray exch get % x y DisplayItem
X 3 1 roll % DI x y
X 2 copy OldDraw2DHexAt % DI x y
X exch HexWidth 2 div add exch % (N) x' y
X moveto % (n)
X dup DisplayItemSize 2 div neg exch 2 div neg exch rmoveto
X DisplayItemPaint
X} def
X
X/FindNeighbours { % row col FindNeighbours [ [x y] null null null null null ]
X 6 dict begin
X /Col exch def
X /Row exch def
X /Z Col 2 mod def
X /Neighbours [ null null null null null null ] def
X Col 0 gt {
X Neighbours 0 [ Row Z add Col 1 sub ] put
X Neighbours 5 [ Row 1 sub Z add Col 1 sub ] put
X } if
X Col MineDict /MineCols get 1 sub lt {
X Neighbours 2 [ Row Z add Col 1 add ] put
X Neighbours 3 [ Row Z add 1 sub Col 1 add ] put
X } if
X Row 0 gt {
X Neighbours 4 [ Row 1 sub Col ] put
X } {
X Z 0 eq {
X Neighbours 3 null put
X Neighbours 5 null put
X } if
X } ifelse
X Row MineDict /MineRows get 1 sub lt {
X Neighbours 1 [ Row 1 add Col ] put
X } {
X Z 1 eq {
X Neighbours 0 null put
X Neighbours 2 null put
X } if
X } ifelse
X Neighbours
X end
X} def
X
X/CoordsToPoint {
X dup 2 mod 0 eq {
X HexDHeight
X } {
X HexHeight
X } ifelse
X 3 1 roll % offset Row Col
X
X HexHDelta mul % offset Row x
X exch HexHeight mul % x bottom-of-hex-if-odd
X
X 3 -1 roll add % x y
X} def
X
X/VisualEffectForWinning {
X gsave
X 6 setrasteropcode
X Color { 2 } { 5 } ifelse % it's faster in mono!
X {
X clippath fill
X pause
X [0 1000000 20 div cvi] sleep
X clippath fill
X } repeat
X grestore
X} def
X
X/VisualEffectForLosing {
X gsave
X 6 setrasteropcode
X Color { 2 } { 5 } ifelse % it's faster in mono!
X {
X clippath fill
X pause
X [0 1000000 20 div cvi] sleep
X clippath fill
X } repeat
X grestore
X % I don't think I like the fissures very much:
X % gsave
X % newpath
X % DrawFissures
X % grestore
X} def
X
X/MakeFissure { % x y length angle thickness -> -
X MineDict begin
X /FissureCount FissureCount 1 add def
X FissureCount (F%) sprintf % construct a key
X end % key
X FissureDict exch 6 dict dup % + dict key value value
X 4 1 roll % value dict key value
X put
X % value
X begin % x y length angle thickness
X /Thickness exch def
X /Angle exch def
X /Length exch def
X /y exch def
X /x exch def
X end
X} def
X
X/DrawFissures { % x y -
X % initialise
X /FissureDict growabledict def
X MineDict /FissureCount 0 put
X
X % Makefissures
X 4 {
X % x y
X 2 copy
X 75 random mul random mul % length
X 360 random mul
X HexDepth 2 mul 1 random random mul sub mul
X MakeFissure
X } repeat
X
X pop pop
X
X % draw the fissures spreading out
X {
X MineDict /FissureCount get 0 le { exit } if
X
X FissureDict {
X % name dict
X begin
X % name
X Thickness setlinewidth
X x y moveto
X /x Length Angle cos mul x add def
X /y Length Angle sin mul y add def
X x y lineto stroke
X /Angle Angle 90 random mul 45 sub add def
X /Thickness Thickness 1 random random mul sub mul def
X /Length Length 1 random random mul sub def
X % name
X mark exch
X Length 5 lt Thickness 0.1 le or
X end % name bool
X
X {
X % name
X FissureDict exch undef
X MineDict /FissureCount get 1 sub % n
X MineDict /FissureCount 3 -1 roll put
X } {
X pop % don't care about the the name
X } ifelse
X [ 0 50000 ] sleep
X pause pause pause
X mark ne {
X deary me
X } if
X } forall
X
X MineDict /FissureCount get 0 le { exit } if
X
X 0.01 random lt {
X FissureDict dup
X MineDict /FissureCount get 1 add random mul cvi
X (F%) sprintf dup
X % dict dict key key
X 3 1 roll known {
X % dict key
X get begin
X x y
X Length .75 mul
X Angle 90 random mul 45 sub add
X Thickness
X end
X MakeFissure
X } {
X pop pop
X } ifelse
X } if
X
X } loop
X} def
X
X/ShowMines {
X gsave
X SetBombFont
X MineBoard {
X % /Key Value
X aload pop
X CoordsToPoint
X % /Key x y
X exch HexWidth 2 div add exch
X % x y of centre of hex
X BombGlyph DisplayItemSize % x y w h
X 2 div neg exch 2 div neg exch
X xyadd moveto
X BombGlyph DisplayItemPaint
X pop % get rid of /Key
X } forall
X grestore
X} def
X
X/IsThereAMineHere? { % Row Col -> bool
X (%-%) sprintf
X % name
X MineBoard exch known
X % bool
X} def
X
X/LayMines { % rows cols n_mines LayMines -
X 10 dict begin
X /n exch def
X n 0 le {
X /n 1 def
X } if
X /Rows MineDict /MineRows get def
X /Cols MineDict /MineCols get def
X
X (New Game...) (%...)[n] sprintf /setfooter window1 send
X
X /MineCount n def
X {
X n 0 eq { exit } if
X
X % Lay one mine
X random Rows mul cvi
X random Cols mul cvi
X 2 copy % Row Col Row Col
X 2 copy % Row Col Row Col Row Col
X (%-%) sprintf dup % Row Col name name
X
X MineBoard exch known {
X % It's already there...
X
X % Row Col Row Col name
X
X pop pop pop pop pop
X % let other things run if we're checking the same cell a lot:
X pause pause pause
X } {
X % Row Col Row Col name
X 3 1 roll % row col name row col
X 2 array astore % row col name [row col]
X MineBoard 3 1 roll % row col dict name [row col]
X put % Row Col
X GetNeighbours {
X dup null eq {
X pop
X } {
X aload pop
X % AddNearbyMine:
X 2 copy Rows mul add % index
X MineDict /NearbyMines get exch get
X 1 add
X % Row Col value
X 3 1 roll % value Row Col
X Rows mul add % value index
X exch % index value
X MineDict /NearbyMines get % index value array
X 3 1 roll
X % Array index value
X put
X } ifelse
X } forall
X /n n 1 sub def
X n 16 mod 2 eq {
X (New Game...) (Laying % Mines)[n] sprintf /setfooter window1 send
X } if
X pause
X } ifelse
X } loop
X
X MineDict /MineCount MineCount put
X end
X} def
X
X/HelpCanvas ClassCanvas
Xdictbegin
X /vspace 18 def
X /textsize 16 def
Xdictend
Xclassbegin
X % stolen shamelessly from $OPENWINHOME/demo/fontview
X /minsize {
X 300 385
X } def
X
X /firstline {
X 10 354 moveto
X } def
X
X /nextline {
X currentpoint exch pop
X vspace sub 10 exch moveto
X } def
X
X /BackgroundColor {
X Color {
X BG
X } {
X 1 1 1 rgbcolor
X } ifelse
X dup /BackgroundColor exch promote
X } def
X
X /Paint {
X BackgroundColor FillCanvas
X
X ForegroundColor setcolor
X /Palatino-Roman findfont textsize scalefont setfont
X
X firstline (HexSweeper) show
X nextline (Copyright )
X /Symbol findfont textsize scalefont setfont (\343) show
X /Palatino-Roman findfont textsize scalefont setfont
X ( Liam Quin, 1992) show
X
X nextline ( ) show
X nextline (HexSweeper is a version of the VMS) show
X nextline (minesweeper game for OpenWindows 3.) show
X nextline ( ) show
X
X nextline (The game window shows a number of) show
X nextline (hexagons. There are explosive mines) show
X nextline (under some of them. You must put a) show
X nextline (Mark \(with the `m' key\) over every) show
X nextline (mine, but ) show
X currentfont
X /Palatino-Italic findfont textsize scalefont setfont
X (not) show
X setfont
X ( over any empty hexagons.) show
X nextline (In order to help you, when you step on) show
X nextline (a hexagon \(press the left mouse buttom) show
X nextline (over a it, or press the space bar\) the) show
X nextline (number of mines under the adjoning) show
X nextline (hexagons will be shown. If there are no) show
X nextline (nearby mines, you could step safely on) show
X nextline (all of the nearby hexagons, but that) show
X nextline (would be tedious, so HexSweeper does) show
X nextline (it for you.) show
X } def
Xclassend def
X
X/ShowHelp {
X /reshaped? help_win send not {
X /place help_win send
X } if
X /pin help_win send
X /totop help_win send
X /map help_win send
X} def
X
X/HexCanvas ClassCanvas
Xdictbegin
X /canvasWidth HexHDelta 6 mul def
X /canvasHeight HexHeight 6 mul def
X /Difficulty 1 6 div def
X
X /MineFont /Palatino-Roman findfont HexHWidth 1.5 div scalefont def
X /OldX -20000 def
X /OldY -30000 def
Xdictend
Xclassbegin
X %% default window size
X
X /preferredsize {
X 550 300
X % HexHDelta 10 mul HexDWidth add 2 add
X % HexHeight 6 mul HexDHeight add 2 add
X } def
X
X /minsize {
X HexWidth 5 mul
X HexHeight 4 mul
X } def
X
X /SetDifficulty {
X /Difficulty exch promote
X Difficulty 1.0 gt Difficulty 0 le {
X /Difficulty 1 6 div def
X } if
X } def
X
X /SetOldXY {
X self begin
X /OldY exch def /OldY OldY promote
X /OldX exch def /OldX OldX promote
X end
X } def
X
X /ChangeFont {
X /item exch send
X aload pop % this seems to be a bug work around
X
X /HexFont exch 1 array astore cvx def
X /HexBoldFont HexFont def
X MakeGlyphs
X /PaintAll self send
X } def
X
X /StopTimer {
X MineDict /GameInProgress false put
X MineDict /TimerInterest known {
X MineDict begin
X /Counting false def % stop the timer!
X TimerInterest null ne {
X TimerInterest revokeinterest
X /TimerInterest null def
X } if
X end
X } {
X MineDict /Counting false put
X } ifelse
X } def
X
X /EndTimer {
X HexTimerProcess killprocess
X StopTimer
X } def
X
X /StartTimer {
X MineDict /Counting get {
X StopTimer
X } if
X MineDict begin
X /Counting true def
X /SecondsSoFar 0 def
X /TimerInterest createevent dup begin
X /Name 1 dict dup begin
X /HexTimerEvent {
X /HexTimer canvas1 send
X } def
X end def
X /Action (HexTimerEvent) def
X end def
X TimerInterest expressinterest
X end
X } def
X
X /HexTimer {
X MineDict begin
X Counting {
X /SecondsSoFar SecondsSoFar 1 add def
X
X (% Mines left)[MineCount] sprintf
X (% seconds)[SecondsSoFar] sprintf
X /setfooter window1 send
X } if
X end
X pop
X } def
X
X
X /MarkHex { % x y MarkHex
X % x y
X gsave
X 2 copy Draw3DHexAt
X 2 copy exch % x' y' y' x'
X HexWidth 2 div add exch % x' y' x+ y'
X MarkGlyph DisplayItemSize % x y x' y' w h
X 2 div neg exch 2 div neg exch
X % x y x y w h
X xyadd moveto
X % x y of leftmost corner
X FG setcolor
X MarkGlyph DisplayItemPaint
X % x y
X 2 copy PointToCoords IsThereAMineHere? {
X % x y
X 2 copy
X PointToCoords (%-%) sprintf PlacesBeen exch true put % -
X MineDict begin
X /MineCount MineCount 1 sub def
X MineCount 0 eq {
X StopTimer
X () (You Won in only % seconds!) [SecondsSoFar] sprintf
X /setfooter window1 send
X VisualEffectForWinning
X } {
X pop pop
X } ifelse
X end % MineDict
X } {
X 2 copy % x y
X WrongMarkGlyph DisplayItemSize % x y x y w h
X 2 div neg exch 2 div neg HexWidth 2 div add exch
X xyadd moveto
X WrongMarkGlyph DisplayItemPaint
X StopTimer
X % x y
X VisualEffectForLosing
X % -
X ShowMines
X } ifelse
X grestore
X } def
X
X /DrawBoard { % width height DrawBoard -
X 18 dict begin
X /BoardHeight exch def
X /BoardWidth exch def
X % We will use an off-screen canvas to hold two columns of hexes -
X % actually from the middle of one through all of another and on to
X % the middle of a third. We can then repeat this canvas to draw the
X % game board quickly.
X
X /TmpCan canvas1 newcanvas def
X /TmpWid HexWidth HexHWidth add def
X
X /TinyCan canvas1 newcanvas def
X TinyCan 0 0 HexWidth 2 mul HexHWidth add HexHeight rectpath reshapecanvas
X TmpCan 0 0
X % width:
X TmpWid
X % height:
X MineDict /MineRows get HexHeight mul HexDHeight add
X rectpath reshapecanvas
X
X % TmpCan /Mapped true put % for debugging
X % TinyCan /Mapped true put
X
X TinyCan setcanvas
X gsave
X BG FillCanvas
X % Draw things HexDHeight "too low"...
X
X 0 0 Draw3DHexAt
X 0 HexHeight Draw3DHexAt
X HexHDelta HexDHeight Draw3DHexAt
X HexHDelta HexHeight HexDHeight add Draw3DHexAt % off the top?
X HexHDelta 2 mul dup
X % x
X 0 Draw3DHexAt
X % x
X HexHeight Draw3DHexAt
X grestore
X
X % draw Col 0 on the main canvas:
X canvas1 setcanvas
X gsave
X BG FillCanvas
X
X 0 HexDHeight translate
X % row 0 on the main screen:
X 0 1 MineDict /MineRows get 2 sub {
X TinyCan imagecanvas
X pop 0 HexHeight translate
X } for
X grestore
X
X % have to do the corners ourselves:
X gsave
X % bottom corners of cols 0 and 2:
X 0 HexDHeight Draw3DHexAt
X HexWidth HexHWidth add HexDHeight Draw3DHexAt
X % top corners of cols 0 and 2:
X MineDict /MineRows get HexHeight mul HexDHeight sub
X % y
X dup
X 0 exch Draw3DHexAt
X dup HexWidth HexHWidth add exch Draw3DHexAt
X % the top middle one:
X HexDHeight add HexHDelta exch Draw3DHexAt
X grestore
X
X % copy that to the off-screen canvas:
X gsave
X TmpCan setcanvas
X BG FillCanvas
X
X HexWidth 2 div neg 0 translate
X canvas1 imagecanvas
X
X grestore
X
X canvas1 setcanvas
X
X gsave
X
X % draw central columns:
X HexWidth 2 div 0 translate
X /Col 1 def
X 1 2 MineDict /MineCols get 2 sub {
X pop
X TmpCan imagecanvas
X TmpWid 0 translate
X /Col Col 2 add def
X } for
X
X grestore
X
X gsave
X % draw rightmost column or two
X /Col Col 1 sub def
X /x Col HexHDelta mul def
X x 0 moveto
X /Indent HexDHeight def
X Col 1 MineDict /MineCols get 1 sub {
X /Col exch def
X /y Indent def
X 0 1 MineDict /MineRows get 1 sub {
X /Row exch def
X x y Draw3DHexAt
X
X x HexDWidth add y moveto
X % (%,%) [Row Col] sprintf show
X
X /y y HexHeight add def
X } for
X /x x HexHDelta add def
X /Indent
X Indent HexDHeight eq {
X HexHeight
X } {
X HexDHeight
X } ifelse
X def
X } for
X grestore
X
X end
X } def
X
X /NewGame {
X MineDict /GameInProgress false put
X /Busy /setvisualstate window1 send
X
X % set the cursor to a stopwatch:
X /busy /setcursor window1 send
X
X (New Game...) (Stopping timer) /setfooter window1 send
X
X MineDict /Counting get {
X StopTimer
X } if
X MineDict /MineCount 0 put
X
X 2 copy % Rows Cols Rows Cols
X
X 2 copy MineDict /MineCols get ne
X exch MineDict /MineRows get ne or {
X (New Game...) (recomputing) /setfooter window1 send
X MineDict begin
X /MineCols exch def
X /MineRows exch def
X end
X RecomputeNeighbours
X } {
X pop pop
X } ifelse
X
X (New Game...) (Clearing Board...) /setfooter window1 send
X MineDict /MineRows get MineDict /MineCols get ClearMines
X % Row Col
X mul Difficulty mul cvi LayMines
X
X MineDict /MineCols get HexHDelta mul
X MineDict /MineRows get HexHeight mul
X (New Game...) (Drawing new Board...) /setfooter window1 send
X DrawBoard
X
X /basic /setcursor window1 send
X MineDict /GameInProgress true put
X /Active /setvisualstate window1 send
X -10000 -10003 /SetOldXY canvas1 send
X (Ready!)() /setfooter window1 send
X } def
X
X /StepGingerly { % x y StepGingerly -
X self setcanvas
X % Draw a flat (2D) hex here:
X FindHexWestPoint
X 2 copy % x y x y
X PreviewFootstep % side effect: flattens the hex (but no glyph drawn)
X OldX OldY PointToCoords % x y r c
X 2 copy IsThereAMineHere? { % x y r c
X StopTimer
X pop pop % x y
X 2 copy moveto (bang!) show
X VisualEffectForLosing
X ShowMines
X % Start New Game...
X } {
X % x y r c
X 2 copy % x y r c r c
X GetNearbyMines % x y r c n
X dup 0 eq {
X % x y r c n
X pop 4 2 roll pop pop
X % r c
X unblockinputqueue
X DoAutoWalk
X } {
X % x y r c n
X 5 1 roll pop pop
X % n x y
X 2 copy 5 -1 roll % x y x y n
X DrawHexGlyphAt
X % x y
X PointToCoords (%-%) sprintf PlacesBeen exch true put % -
X } ifelse
X
X MineDict /Counting get not {
X StartTimer
X } if
X
X } ifelse
X -10000 -10003 /SetOldXY self send
X } readonly def
X
X /CancelPreviewFootstep { % - -> -
X OldX -1000 ge {
X OldX OldY PointToCoords (%-%) sprintf
X PlacesBeen exch known not {
X OldX OldY Draw3DHexAt % restore old hex
X } if
X } if
X -10000 -10000 /SetOldXY self send
X } def
X
X /PreviewFootstep { % x y PreviewFootstep -
X % x y
X 2 copy PointToCoords (%-%) sprintf
X % x y name
X PlacesBeen exch known not {
X 2 copy Draw2DHexAt
X } if
X % x y
X 2 copy % x y x y
X OldY ne % x y x bool
X exch OldX ne % x y bool bool
X or { % x y
X CancelPreviewFootstep
X % x y
X /SetOldXY self send
X } {
X pop pop
X } ifelse
X } def
X
X /TrackStart {
X /E exch def
X self setcanvas
X E /Name get dup (LeftMouseButton) eq exch (MiddleMouseButton) eq or {
X -10001 -10002 /SetOldXY self send
X MineDict /GameInProgress get {
X E /Coordinates get aload pop CheckInRange {
X E /Coordinates get aload pop
X FindHexWestPoint PreviewFootstep
X [/TrackCrossing /TrackMotion /TrackStop] true
X } {
X nullarray true
X } ifelse
X } {
X (Use n to start a new game)() /setfooter window1 send
X nullarray true
X } ifelse
X } {
X false
X } ifelse
X } def
X
X /TrackCrossing {
X /TrackCancel self send
X } def
X
X /TrackMotion {
X dup /E exch def begin
X E /Coordinates get aload pop
X 2 copy CheckInRange {
X FindHexWestPoint PreviewFootstep
X } {
X CancelPreviewFootstep
X } ifelse
X end
X % /TrackMotion super send
X } def
X
X /TrackStop {
X /E exch def
X mark
X self setcanvas
X E /Coordinates get aload pop CheckInRange {
X E /Name get (LeftMouseButton) eq {
X E /Coordinates get aload pop
X FindHexWestPoint
X 2 copy PointToCoords (%-%) sprintf
X PlacesBeen exch known {
X pop pop %% beep % bebop pebop bepop
X } {
X StepGingerly
X } ifelse
X } {
X E /Name get (MiddleMouseButton) eq {
X E /Coordinates get aload pop 2 copy CheckInRange {
X FindHexWestPoint
X 2 copy PointToCoords (%-%) sprintf
X PlacesBeen exch known {
X beep pop pop
X } {
X MarkHex
X } ifelse
X } {
X pop pop
X } ifelse
X } {
X (Unknown Event) E /Name get /setfooter window1 send
X } ifelse
X } ifelse
X } {
X CancelPreviewFootstep
X } ifelse
X E /TrackStop super send
X cleartomark
X } def
X
X /TrackCancel {
X /E exch def
X CancelPreviewFootstep
X E /TrackCancel super send
X } def
X
X %% Input events (key presses):
X /StandardKeyUp {
X /E exch def
X self setcanvas
X E /Name get {
X 12 18 { % control-L, control-R --> redraw
X /Paint self send
X }
X 8 72 104 56 77 28 { % h, ? = help
X ShowHelp
X }
X 77 109 { % M, m = mark
X E /Coordinates get aload pop
X FindHexWestPoint
X 2 copy PointToCoords (%-%) sprintf PlacesBeen exch known {
X beep pop pop
X } {
X MineDict /GameInProgress get {
X MarkHex
X } {
X pop pop beep
X } ifelse
X } ifelse
X }
X 78 110 { % N, n - new game
X MineDict /MineRows get
X MineDict /MineCols get
X NewGame
X }
X 17 81 113 { % ^Q, Q, q --> quit
X /QuitFromUser window1 send
X }
X 19 { % ^S - show mines and give up
X ShowMines % this lets you cheat...
X % later, this will show the scores..
X }
X % p, properties
X 32 { % space --> StepGingerly
X E /Coordinates get aload pop
X FindHexWestPoint 2 copy
X PointToCoords (%-%) sprintf PlacesBeen exch known {
X beep pop pop
X } {
X MineDict /GameInProgress get {
X StepGingerly
X } {
X pop pop beep
X } ifelse
X } ifelse
X }
X /Default {
X beep
X }
X } case
X } def
X
X /FunctionKeyUp {
X /Name get /FunctionL3 eq {
X % Props. I wish I got a "Properties" event instead, though.
X % But you need to have selections if you do that.
X /ShowProps self send
X } if
X } def
X
X /KeyStart { pop [ /StandardKeyUp /FunctionKeyUp ] true} def
X
X %% Startup code:
X /NewInit {
X /OldX -10341 promote
X /OldY -10342 promote % unusual numbers for easy spotting...
X
X % Arrange to be allowed focus:
X MineFont /setfont self send
X
X /NewInit super send
X } def
X
X %% The hexes...
X /Paint {
X gsave
X BG FillCanvas
X grestore
X
X (Drawing...) ( ) /setfooter window1 send
X /Busy /setvisualstate window1 send
X
X % canvas size -- TNT 3.0 Ref. p. 49
X bbox /canvasHeight exch def /canvasWidth exch def pop pop
X /Rows canvasHeight HexDHeight 2 div sub HexHeight div cvi def
X /Cols canvasWidth HexHDelta div cvi def
X Rows Cols NewGame
X (Type h for help...) ( ) /setfooter window1 send
X
X % ShowMines % for cheating
X
X /Active /setvisualstate window1 send
X } def
X
Xclassend def
X
X/canvas1 framebuffer /new HexCanvas send def
X/window1 canvas1 framebuffer /new ClassBaseWindow send def
XMyName /setlabel window1 send
X{
X /PaintIcon {
X 20 dict begin
X gsave
X IconFont setfont
X /OldSize HexHWidth def
X 25 SetHexSizeFromFlat
X
X 0 0 moveto
X /s (SWEEPER) def
X /t [
X (HEX)
X IconFont 2 scalefont
X 0 0.5 0.5 rgbcolor
X ] def
X s show
X t DisplayItemSize /ty exch def /tx exch def
X
X % Move above the icon name
X 0
X s DisplayItemSize exch pop % y
X translate
X
X % Draw a hex
X 0 HexDHeight Draw3DHexAt
X
X % move to middle of bottom left diagonal:
X HexDWidth 2 div HexDHeight 2 div translate
X
X % draw the word HEX
X
X 30 rotate
X
X 0 0 moveto
X % centre of the hex is at (HexHWidth) * sqrt3 / 2, 0
X HexHWidth sqrt3 mul 2 div 0
X
X % centre of hex on stack...
X tx 2 div neg ty 2 div neg xyadd
X
X moveto
X t DisplayItemPaint
X OldSize SetHexSizeFromFlat
X grestore
X end
X } def
X
X /QuitFromUser {
X /EndTimer canvas1 send
X currentprocess killprocess
X } def
X
X} window1 send
X
X/new ClassEventMgr send dup /ProcessName (Hex) put
X
X/help_can framebuffer /new HelpCanvas send def
X/help_win help_can framebuffer /new ClassPopupWindow send def
Xhelp_win /addsubwindow window1 send
X
X
X(HexSweeper Help) /setlabel help_win send
X
X/nFonts 0 def
X
X/menu /Grid framebuffer /new ClassMenu send def
X[
X [
X (New game) {
X pop pop
X /PaintAll canvas1 send
X }
X ]
X [ (Properties...) { pop pop beep } ]
X
X [
X (Difficulty)
X
X /Grid framebuffer /new ClassMenu send
X dup
X [
X [
X (Suicide) {
X pop pop
X .5 /SetDifficulty canvas1 send
X /PaintAll canvas1 send
X }
X ]
X [
X (Very Difficult) {
X pop pop
X .3 /SetDifficulty canvas1 send
X /PaintAll canvas1 send
X }
X ]
X [
X (Normal) {
X pop pop
X 1 6 div /SetDifficulty canvas1 send
X /PaintAll canvas1 send
X }
X ]
X [
X (Easy) {
X pop pop
X 1 12 div /SetDifficulty canvas1 send
X /PaintAll canvas1 send
X }
X ]
X [
X (Dan Quayle) {
X pop pop
X 1 100 div /SetDifficulty canvas1 send
X /PaintAll canvas1 send
X }
X ]
X ]
X exch /setitemlist exch send
X ]
X
X [
X (HexFont)
X /Grid framebuffer /new ClassMenu send
X [
X FontDirectory {
X type /nametype eq {
X pop
X } {
X 255 string cvs
X % exclude this font if it has OpenLook in the name.
X (OpenLook) search { pop pop pop } {
X % or if it is the olgx font.
X (olglyph) search { pop pop pop } {
X % or if it is a bogus Xt+ font.
X (12) search { pop pop pop } {
X % or if it has an XLFD long name.
X dup length 30 gt { pop } {
X /nFonts nFonts 1 add store
X } ifelse
X } ifelse
X } ifelse
X } ifelse
X } ifelse
X } forall
X ] /gt quicksort /setitemlist 2 index send
X /ChangeFont /setnotifier 2 index send
X [ true nFonts 3 add 4 idiv 4 ] /setlayoutparameters 2 index send
X /textfont 1 index send /FontName get
X findfont 11 scalefont /settextfont 2 index send
X true /setpinnable 2 index send
X % @@
X ]
X
X [
X (Scale)
X
X /Grid framebuffer /new ClassMenu send
X dup [
X [
X (Texas) {
X pop pop % 300 was too big...
X 200 /SetHexSizeFromFlat canvas1 send
X /PaintAll canvas1 send
X }
X ]
X [
X (Huge) {
X pop pop % 300 was too big...
X 60 /SetHexSizeFromFlat canvas1 send
X /PaintAll canvas1 send
X }
X ]
X [
X (Big) {
X pop pop 40 /SetHexSizeFromFlat canvas1 send
X /PaintAll canvas1 send
X }
X ]
X [
X (Large) {
X pop pop 30 /SetHexSizeFromFlat canvas1 send
X /PaintAll canvas1 send
X }
X ]
X [
X (Normal) {
X pop pop 25 /SetHexSizeFromFlat canvas1 send
X /PaintAll canvas1 send
X }
X ]
X [
X (Smallish) {
X pop pop 20 /SetHexSizeFromFlat canvas1 send
X /PaintAll canvas1 send
X }
X ]
X [
X (Tiny) {
X pop pop 14 /SetHexSizeFromFlat canvas1 send
X /PaintAll canvas1 send
X }
X ]
X [
X (Welsh Cottage) {
X pop pop 7 /SetHexSizeFromFlat canvas1 send
X /PaintAll canvas1 send
X }
X ]
X ] exch /setitemlist exch send
X ]
X [ (Quit) { pop pop /QuitFromUser window1 send } ]
X] /setitemlist menu send
Xtrue /setpinnable menu send
Xmenu /setmenu canvas1 send
Xtrue /setmenuable canvas1 send
Xtrue /setkeyable canvas1 send
Xtrue /settrackable canvas1 send
X
X/activate window1 send
Xwindow1 /Retained true put
X/place window1 send
X/map window1 send
Xpause pause pause
X
@@@End of hexsweeper
chmod +x hexsweeper
echo end of archive from:
cat # print .signature...
--
Liam Quin, lee@sq.com, SoftQuad, Toronto, 416 239-4801; the barefoot programmer
lq-text (Unix text retrieval package) mailing list: lq-text-request@sq.com
latest released version: 1.10; ftp: ftp.cs.toronto.edu in directory: pub
If Adultery is for Adults, is Juvenal for Juveniles?
Thread Navigation
This is a paginated view of messages in the thread with full content displayed inline.
Messages are displayed in chronological order, with the original post highlighted in green.
Use pagination controls to navigate through all messages in large threads.
Back to All Threads