leif@SUN.COM (Leif Samuelsson) (06/06/89)
I stumbled on this old demo and realized that it probably
never made it out to the world. It still needs some fine tuning
if anybody is interested. Enjoy!
Leif Samuelsson leif@sun.com
Sun Microsystems, Inc
#! /usr/NeWS/bin/psh
%
% puzzle
%
% Puzzle is an interactive jig-saw puzzle program.
% The pieces can be moved around with the middle mouse
% button. The menu contains a "solve" command and also
% allows for changing image in mid-game.
%
% 890604 Made public domain - posted to Usenet
% 871022 Fixed bugs - works with NeWS 1.1
% 870601 Rewrote using o.o.p.
% 870416 Made it work with NeWS 1.0
% 870127 First release
%
% Author: Leif Samuelsson, Sun Microsystems, Inc.
8 setretainthreshold
/NROWS 4 def
/NCOLS { NROWS } def
/NPIECES { NROWS NCOLS mul } def
/BACKGROUND .9 def
% Setting curve to false causes the pieces to be rectangular
% instead of interlocking. This speeds up the program considerably.
/curve false def
/imagedirectory (/usr/NeWS/smi/) def
/fileextension (.im8) def
/picfile (man) def
/picimage
currentcanvas newcanvas
dup makecanvasopaque
dup makecanvasretained
def
/readimage {
gsave
0 0 moveto
piecewidth NCOLS mul pieceheight NROWS mul rect
picimage
dup reshapecanvas
setcanvas
imagedirectory picfile append
fileextension append
readcanvas
wscale hscale scale
imagecanvas
grestore
} def
% Define a class "Piece" which knows how to draw
% and move itself.
%
/Piece Object [/Row /Column /TheCanvas /EventMgr /Path] classbegin
/new { % Row Column parentcanvas => inst.
/new super send begin
/TheCanvas exch newcanvas store
/Column exch store
/Row exch store
gsave
initmatrix
TheCanvas
dup makecanvasopaque
dup mapcanvas
dup makecanvasretained
random piecewidth NCOLS 3 mul 2 div 1 sub mul mul
random pieceheight NROWS 3 mul 2 div 1 sub mul mul
/xarc 48 def
translate
0 0 moveto
Row 0 ne curve and
{ piecewidth 2 div
pieceheight 8 div
pieceheight 6 div
180 xarc add
360 xarc sub
arcn
} if
piecewidth 0 lineto
Column NCOLS 1 sub ne curve and
{ piecewidth dup 8 div add
pieceheight 2 div
piecewidth 6 div
270 xarc sub
90 xarc add
arc
} if
piecewidth pieceheight lineto
Row NROWS 1 sub ne curve and
{ piecewidth 2 div
pieceheight dup 8 div add
pieceheight 6 div
360 xarc sub
180 xarc add
arc
} if
0 pieceheight lineto
Column 0 ne curve and
{ piecewidth 8 div
pieceheight 2 div
piecewidth 6 div
90 xarc add
270 xarc sub
arcn
} if
closepath
/Path currentpath store
reshapecanvas
grestore
/EventMgr [
currentdict % piece
TheCanvas % piece can
MiddleMouseButton % piece can name
[ /move % piece can name [ /move
5 -1 roll % can name [ /move piece
/send cvx ] cvx % can name proc
DownTransition % can name proc action
4 -1 roll % name proc action can
eventmgrinterest
] forkeventmgr store
currentdict
end
} def
/killeventmgr {
EventMgr /EventMgr null store killprocess
} def
/paint {
TheCanvas setcanvas
gsave
Column piecewidth mul neg
Row pieceheight mul neg
translate
wscale hscale scale
picimage imagecanvas
grestore
% 0 strokecanvas
} def
/slidehome {
{
can setcanvas
1 1 22 {
gsave
TheCanvas getcanvaslocation % x y
TheCanvas setcanvas
Column .5 add piecewidth mul
Row .5 add pieceheight mul % x y x' y'
3 -1 roll % x x' y' y
dup add add 3 div round % x x' y"
3 1 roll exch % y" x' x
dup add add 3 div round % y" x"
exch
movecanvas
grestore
pause
} for
TheCanvas setcanvas
Column .5 add piecewidth mul
Row .5 add pieceheight mul
movecanvas
} fork
} def
/center {
TheCanvas setcanvas
wscale 2 div hscale 2 div movecanvas
} def
/qsolve {
TheCanvas setcanvas
Column .5 add piecewidth mul
Row .5 add pieceheight mul
movecanvas
} def
/randomize {
TheCanvas setcanvas
random piecewidth NCOLS 3 mul 2 div 1 sub mul mul
random pieceheight NROWS 3 mul 2 div 1 sub mul mul
movecanvas
} def
/move {
15 dict begin
/xo null def /yo null def
gsave
can setcanvas
TheCanvas getcanvaslocation % x y
initmatrix
can setcanvas
currentcursorlocation % x y x' y'
3 -1 roll % x x' y' y
sub /yo exch store
exch sub /xo exch store
BACKGROUND setgray
0 0 {
gsave
TheCanvas setcanvas
yo sub exch xo sub exch
movecanvas
grestore
} xgetanimated waitprocess aload pop
grestore
end
} def
classend def % End of class "Piece"
/Pieces NPIECES array def
/piecewidth 0 def
/pieceheight 0 def
/wscale { piecewidth NCOLS mul } def
/hscale { pieceheight NROWS mul } def
/restart {
Pieces { /killeventmgr exch send } forall
/Pieces NPIECES array store % This causes g.c. of old pieces
pause
newpieces
paintpieces
/paint win send
} def
/xgetanimated {
10 dict begin
/proc exch def /y0 exch def /x0 exch def
currentcursorlocation /y exch def /x exch def
GA_constraint null ne GA_value null eq and {
/GA_value currentcursorlocation GA_constraint 1 eq {exch} if pop store
} if
{ createevent dup begin
/Action [UpTransition DownTransition] def
end expressinterest
createevent dup /Name /MouseDragged put expressinterest
{
GA_constraint 0 eq {/x GA_value def} if
GA_constraint 1 eq {/y GA_value def} if
x0 y0 moveto x y /proc load exec
awaitevent begin
Action UpTransition eq { end exit } if
/x XLocation store /y YLocation store
end
} loop
/GA_constraint null store
/GA_value null store
[x y]
} fork
end
} def
/newpieces { % - newpiece piece
2 dict begin
can setcanvas
clippath pathbbox
/pieceheight exch 2 mul 3 div NROWS div round store
/piecewidth exch 2 mul 3 div NCOLS div round store
pop pop
readimage
0 1 NROWS 1 sub {
/i exch def
0 1 NCOLS 1 sub {
/j exch def
i j can /new Piece send
Pieces exch i NCOLS mul j add exch put
} for
} for
end
}def
/paintpieces {
Pieces {/paint exch send} forall
} def
/menuselect {
/picfile MenuKeys MenuValue get store
readimage
paintpieces
} def
/davincipicturemenu [
(angel)
(ermine)
(lady)
(man)
(mona-face)
(mona-hands)
(mona-smile)
% (mona-smile-hires)
(mona)
(stjerome)
(virgin)
(virginofrocks)
] [{ menuselect }] /new DefaultMenu send def
/japanesepicturemenu [
(cherries)
(fuji)
(geese)
(puppet)
(snow)
(stormy)
(washing)
% (washing-hires)
(writing)
] [{ menuselect }] /new DefaultMenu send def
/sunpicturemenu [
(founders)
(sun3110)
(sun3160c)
(sun3160m)
(sun3260h)
(sun350)
(sun352)
(sun352w)
(sunballs)
(suncase)
(sungame)
(sunnet)
(sunnfs)
(sunprism)
] [{ menuselect }] /new DefaultMenu send def
/travelpicturemenu [
(bryce)
(harem)
(joshua)
(lascruces)
(new_york)
(pagosa)
(saturn)
(shroom)
(taj-detail)
(taj)
(veggies)
(zion)
] [{ menuselect }] /new DefaultMenu send def
/winpicturemenu [
(Da Vinci =>) davincipicturemenu
(Japanese =>) japanesepicturemenu
(Sun =>) sunpicturemenu
(Misc =>) travelpicturemenu
] /new DefaultMenu send def
/piecesmenu
[ (1) (4) (9) (16) (25) (36) (49) (64)]
[{ /NROWS MenuValue 1 add store restart }]
/new DefaultMenu send def
/win framebuffer /new DefaultWindow send def
{
/FrameLabel (Puzzle) def
/PaintClient {
ClientCanvas setcanvas
BACKGROUND fillcanvas
} def
/PaintIcon {
gsave
IconCanvas setcanvas
clippath pathbbox scale pop pop
picimage imagecanvas
0 strokecanvas
grestore
} def
/ClientMenu [
(Solve) { Pieces { /slidehome exch send } forall }
(Quick Solve) { Pieces { /qsolve exch send } forall }
(Scatter Pieces) { Pieces { /randomize exch send } forall }
(Stack Pieces) { Pieces { /center exch send } forall }
(Interlock On/Off) { /curve curve not store restart }
(Picture =>) winpicturemenu
(No. of Pieces =>) piecesmenu
(Zap) {currentprocess killprocessgroup}
] /new DefaultMenu send def
} win send
/reshapefromuser win send
/map win send
/can win /ClientCanvas get def
/paint win send
pause
newpieces
paintpieces