(* Copyright (C) 1991, Digital Equipment Corporation *) (* Copyright 1990 David Lemke and Network Computing Devices *) (* Copyright (c) 1989, Donald R. Woods and Sun Microsystems, Inc. *) (* All rights reserved. *) (* See the file COPYRIGHT for a full description. *) (* Last modified on Tue Aug 18 13:11:15 1992 by msm *) (* modified on Fri Sep 20 01:58:26 1991 by kalsow *) MODULE Card; IMPORT Point, VBT, ZSplit, Rect, Random, Time, CardRank, CardSuit, FaceCards, Gray, HighlightVBT, Pixmap, Axis, PaintOp, Region, VBTRep, Filter, MouseSplit, Split, Thread, TwoTone; CONST MidH = Width DIV 2; MidV = Height DIV 2; Mid = Point.T{MidH, MidV}; TenV1 = (3 * Height) DIV 10; TenV2 = Height - TenV1; SevenV = (7 * Height) DIV 20; EightV = Height - SevenV; Col1 = (3 * Width) DIV 10; Col3 = Width - Col1; Row1 = Height DIV 5; Row2 = (2 * Height) DIV 5; Row3 = MidV; Row4 = Height - Row2; Row5 = Height - Row1; RankH = 4; RankV = 7; SuitH = RankH; SuitV = 24; RankNW = Point.T{RankH, RankV}; KnarNW = Point.T{Width - RankH, Height - RankV}; SuitNW = Point.T{SuitH, SuitV}; TiusNW = Point.T{Width - SuitH, Height - SuitV}; VAR realRed := PaintOp.FromRGB(0.75, 0.0, 0.0, bw := PaintOp.BW.UseFg); red := PaintOp.Pair(PaintOp.Bg, realRed); transpRed := PaintOp.Pair(PaintOp.Transparent, realRed); redSwap := PaintOp.SwapPair(PaintOp.Bg, realRed); black := PaintOp.BgFg; transpBlack := PaintOp.TransparentFg; blackSwap := PaintOp.Swap; realFelt := PaintOp.FromRGB(0.2, 0.8, 0.6); feltSwap := PaintOp.SwapPair(PaintOp.Fg, realFelt); back := PaintOp.Pair(PaintOp.Bg, PaintOp.FromRGB(0.16, 0.30, 0.60)); backPix := Pixmap.Gray; REVEAL Private = HighlightVBT.T BRANDED OBJECT END; T = Public BRANDED OBJECT nexthigh: T := NIL; OVERRIDES mouse := Mouse; position := Position; shape := Shape END; <*UNUSED*> CONST Names = ARRAY Value OF TEXT{"Min", "A", "2", "3", "4", "5", "6", "7", "8", "9", "10", "J", "Q", "K", "Max", "Talon"}; Suits = ARRAY Family OF TEXT{"", "S", "H", "D", "C"}; VAR dragSource, dest: T := NIL; high : T := NIL; killGen := 0; tracking := FALSE; highlight := TRUE; chainTime := 1000; log : Log; TYPE UndoRec = RECORD card, prevBelow, newBelow: T; userMade : BOOLEAN END; UndoLog = REF ARRAY OF UndoRec; Log = REF RECORD undo : UndoLog; nextUndo, lastUndo: INTEGER END; PROCEDURE StartUndoLog () = BEGIN IF log = NIL THEN log := NEW(Log) END; IF log.undo = NIL THEN log.undo := NEW(UndoLog, 10) END; log.nextUndo := 0; log.lastUndo := 0; END StartUndoLog; PROCEDURE MoreUndo () = VAR u := NEW(UndoLog, 2 * NUMBER(log.undo^)); BEGIN SUBARRAY(u^, 0, NUMBER(log.undo^)) := log.undo^; log.undo := u END MoreUndo; PROCEDURE Undo (): BOOLEAN = <*FATAL BadDeal*> BEGIN IF log = NIL OR log.nextUndo = 0 THEN RETURN FALSE END; LOOP IF log.nextUndo = 0 THEN EXIT END; DEC(log.nextUndo); WITH u = log.undo[log.nextUndo] DO IF u.prevBelow = NIL THEN Flip(u.card, NOT u.card.faceUp); ELSE Attach(u.card, u.prevBelow); END; IF u.userMade THEN EXIT END END END; RETURN TRUE END Undo; PROCEDURE Redo (slowly: BOOLEAN): BOOLEAN = <*FATAL BadDeal*> VAR c: T; BEGIN IF log = NIL OR log.nextUndo = log.lastUndo THEN RETURN FALSE END; LOOP WITH u = log.undo[log.nextUndo] DO c := u.card; IF u.newBelow = NIL THEN Flip(u.card, NOT u.card.faceUp); ELSE Attach(u.card, u.newBelow); END; END; INC(log.nextUndo); IF log.nextUndo = log.lastUndo THEN EXIT END; IF log.undo^[log.nextUndo].userMade THEN EXIT END; IF slowly THEN VBTRep.Redisplay(); VBT.Sync(c); Time.Pause(100000) END END; RETURN TRUE END Redo; PROCEDURE AddLog (cd, pBelow, nBelow: T; uMade: BOOLEAN) = BEGIN IF (log = NIL) OR (log.undo = NIL) THEN StartUndoLog() END; IF log.nextUndo = NUMBER(log.undo^) THEN MoreUndo() END; WITH u = log.undo[log.nextUndo] DO u.card := cd; u.prevBelow := pBelow; u.newBelow := nBelow; u.userMade := uMade END; INC(log.nextUndo); log.lastUndo := log.nextUndo END AddLog; PROCEDURE Real (c: T): BOOLEAN = BEGIN RETURN (c.value # Value.Min) AND (c.value # Value.Max) AND (c.value # Value.Talon) END Real; PROCEDURE Shape ( <*UNUSED*>ch: T; ax: Axis.T; <*UNUSED*>n: CARDINAL): VBT.SizeRange = BEGIN IF ax = Axis.T.Hor THEN RETURN VBT.SizeRange{lo := Width, pref := Width, hi := Width + 1} ELSE RETURN VBT.SizeRange{lo := Height, pref := Height, hi := Height + 1} END END Shape; PROCEDURE KillHigh (VAR high: T) = VAR next: T; BEGIN WHILE high # NIL DO next := high.nexthigh; high.nexthigh := NIL; HighlightVBT.SetRect(high, Rect.Empty, 0); high := next END; INC(killGen) END KillHigh; PROCEDURE AddHigh (VAR high: T; ch: T) = BEGIN IF ch = NIL OR ch.nexthigh # NIL OR ch = high THEN RETURN END; HighlightVBT.SetRect(ch, VBT.Domain(ch), MAX(Width, Height)); ch.nexthigh := high; high := ch END AddHigh; PROCEDURE Position (ch: T; READONLY cd: VBT.PositionRec) = BEGIN IF cd.cp.gone THEN IF (dragSource # NIL) AND (ch = dragSource) AND (dest # NIL) THEN dest := NIL; KillHigh(high) END; VBT.SetCage(ch, VBT.GoneCage) ELSE IF tracking AND cd.modifiers * VBT.Buttons = VBT.Modifiers{} THEN dragSource := ch; dest := obvious(dragSource); AddHigh(high, dest); IF chainTime >= 0 AND dest # NIL THEN EVAL Thread.Fork(NEW(Lumen, dest := dest, up := TRUE, killGen := killGen, quick := FALSE)) END END; VBT.SetCage(ch, VBT.CageFromRect(VBT.Domain(ch), cd.cp)) END; MouseSplit.Position(ch, cd) END Position; TYPE Lumen = Thread.Closure OBJECT dest : T; up, quick: BOOLEAN; killGen: INTEGER OVERRIDES apply := LumenApply END; PROCEDURE LumenApply (self: Lumen): REFANY = VAR timer: INTEGER; BEGIN IF NOT self.quick THEN LOCK VBT.mu DO timer := chainTime * 10000 END; IF timer < 0 THEN RETURN NIL END; Time.Pause(timer) END; LOOP LOCK VBT.mu DO timer := chainTime * 1000 END; IF timer < 0 THEN EXIT END; Time.Pause(timer); LOCK VBT.mu DO IF killGen # self.killGen THEN EXIT END; IF self.up THEN self.dest := obvious(self.dest) ELSE self.dest := stupid(self.dest) END; IF self.dest = NIL THEN EXIT END; AddHigh(high, self.dest) END END; RETURN NIL END LumenApply; PROCEDURE Mouse (ch: T; READONLY cd: VBT.MouseRec) = VAR prev, next, log: T; BEGIN IF cd.clickType = VBT.ClickType.FirstDown THEN dragSource := ch; CASE cd.whatChanged OF VBT.Modifier.MouseL => dest := obvious(dragSource) | VBT.Modifier.MouseM => dest := trivial(dragSource) | VBT.Modifier.MouseR => dest := stupid(dragSource) ELSE dest := NIL END; KillHigh(high); IF highlight THEN AddHigh(high, dest); IF dest # NIL AND (cd.whatChanged = VBT.Modifier.MouseL OR cd.whatChanged = VBT.Modifier.MouseR) AND chainTime >= 0 THEN EVAL Thread.Fork(NEW(Lumen, dest := dest, up := cd.whatChanged = VBT.Modifier.MouseL, killGen := killGen, quick := TRUE)) END END ELSE KillHigh(high); prev := ch; IF (cd.clickType = VBT.ClickType.LastUp) AND (dragSource # NIL) THEN IF (prev = dragSource) AND NOT cd.cp.gone THEN prev := dest END; IF (prev = NIL) OR (prev = dragSource) THEN dragSource := NIL; RETURN END; TRY IF attachable(dragSource, prev) THEN IF Real(dragSource) THEN log := dragSource.below; Attach(dragSource, prev); AddLog(dragSource, log, prev, TRUE); VBTRep.Redisplay(); END; WHILE play(prev, next) DO VBT.Sync(ch); IF prev = next THEN Flip(prev, NOT prev.faceUp); AddLog(prev, NIL, NIL, FALSE); ELSE log := prev.below; Attach(prev, next); AddLog(prev, log, next, FALSE); VBTRep.Redisplay() END; END; END EXCEPT BadDeal => END END; dragSource := NIL END; MouseSplit.Mouse(ch, cd) END Mouse; PROCEDURE NotAttachable ( <*UNUSED*>a, b: T): BOOLEAN = BEGIN RETURN FALSE END NotAttachable; PROCEDURE NoPlay ( <*UNUSED*>VAR a, b: T): BOOLEAN = BEGIN RETURN FALSE END NoPlay; PROCEDURE NoMove ( <*UNUSED*>a: T): T = BEGIN RETURN NIL END NoMove; PROCEDURE Detach (c: T) = BEGIN IF c.below = c THEN RETURN END; c.below.above := c.above; c.above.below := c.below; c.above := c; c.below := c END Detach; PROCEDURE AttachOne (c, p: T) = (* Put c on top of p *) VAR dom : Rect.T; below: T; BEGIN Detach(c); dom := ZSplit.GetDomain(p); below := Bottom(p); IF (below.value # Value.Min) AND Real(p) THEN IF p.faceUp THEN dom := Rect.MoveV(dom, Overlap) ELSE dom := Rect.MoveV(dom, OverlapDown) END END; ZSplit.Move(c, dom); ZSplit.Lift(c); c.above := p.above; p.above := c; c.below := p; c.above.below := c END AttachOne; PROCEDURE Attach (c, p: T) RAISES {BadDeal} = VAR above: T; BEGIN IF p.above = c OR p = c THEN RETURN END; IF Real(p.above) AND (p.above # p) OR Top(p) = Top(c) THEN RAISE BadDeal END; WHILE (p # c) AND Real(c) DO above := c.above; AttachOne(c, p); p := c; c := above END END Attach; PROCEDURE InitializeStandardDeck (VAR deck: StandardDeck; zSplit: ZSplit.T) = VAR i: INTEGER; BEGIN i := 0; FOR val := Value.Ace TO Value.King DO FOR st := Family.Spades TO Family.Clubs DO deck[i] := New(val, st, Point.Origin, zSplit); INC(i) END END END InitializeStandardDeck; PROCEDURE Flip (c: T; up: BOOLEAN) = VAR old: BOOLEAN; BEGIN old := c.faceUp; c.faceUp := up; IF (old # up) THEN VBT.Mark(Filter.Child(c)) END END Flip; PROCEDURE New ( val : Value; st : Family; READONLY loc : Point.T; zSplit: ZSplit.T; faced : BOOLEAN := TRUE): T = <*FATAL BadDeal*> VAR res := NEW(T, value := val, family := st, faceUp := faced); BEGIN IF NOT Real(res) THEN EVAL HighlightVBT.T.init(res, NIL, feltSwap, Pixmap.Solid) ELSIF st = Family.Hearts OR st = Family.Diamonds THEN EVAL HighlightVBT.T.init(res, NIL, redSwap, Pixmap.Solid) ELSE EVAL HighlightVBT.T.init(res, NIL, blackSwap, Pixmap.Solid) END; res.above := res; res.below := res; Realize(res, loc, zSplit); RETURN res END New; PROCEDURE Realize (c: T; READONLY loc: Point.T; zSplit: ZSplit.T) RAISES {BadDeal} = <*FATAL Split.NotAChild *> BEGIN Split.Insert(c, NIL, NEW(Card)); ZSplit.InsertAt(zSplit, c, loc) END Realize; TYPE Card = VBT.Leaf OBJECT OVERRIDES repaint := Repaint END; PROCEDURE Repaint (v: Card; READONLY bad: Region.T) = VAR t: T := VBT.Parent(v); BEGIN PaintBg(v, t, bad.r); PaintBorder(v, t, bad.r); PaintTopCorners(v, t, bad.r); PaintBottomCorners(v, t, bad.r); IF Real(t) AND t.faceUp THEN PaintRankAndSuit(v, t, bad.r); PaintCenter(v, t, bad.r) END END Repaint; PROCEDURE PaintCenter (v: Card; t: T; READONLY clip: Rect.T) = VAR op, top: PaintOp.T; delta := Rect.NorthWest(VBT.Domain(v)); pix := CardSuit.PipPix(t.family); xip := CardSuit.PipXip(t.family); BEGIN IF t.family = Family.Hearts OR t.family = Family.Diamonds THEN op := red; top := transpRed ELSE op := black; top := transpBlack END; IF t.value >= Value.Jack THEN BorderCenter(v, op, top, clip, FaceCards.Pix(t.family, t.value), Mid, delta, pix, xip, t.family, t.value) ELSIF t.value >= Value.Four THEN Center(v, op, clip, pix, Point.T{Col1, Row1}, delta); Center(v, op, clip, pix, Point.T{Col3, Row1}, delta); Center(v, op, clip, xip, Point.T{Col1, Row5}, delta); Center(v, op, clip, xip, Point.T{Col3, Row5}, delta); IF t.value >= Value.Nine THEN Center(v, op, clip, pix, Point.T{Col1, Row2}, delta); Center(v, op, clip, pix, Point.T{Col3, Row2}, delta); Center(v, op, clip, xip, Point.T{Col1, Row4}, delta); Center(v, op, clip, xip, Point.T{Col3, Row4}, delta); IF t.value >= Value.Ten THEN Center(v, op, clip, pix, Point.T{MidH, TenV1}, delta); Center(v, op, clip, xip, Point.T{MidH, TenV2}, delta); ELSIF t.value >= Value.Nine THEN Center(v, op, clip, pix, Mid, delta); END ELSIF t.value >= Value.Six THEN Center(v, op, clip, pix, Point.T{Col1, Row3}, delta); Center(v, op, clip, pix, Point.T{Col3, Row3}, delta); IF t.value >= Value.Seven THEN Center(v, op, clip, pix, Point.T{MidH, SevenV}, delta); IF t.value >= Value.Eight THEN Center(v, op, clip, xip, Point.T{MidH, EightV}, delta); END END; ELSIF t.value >= Value.Five THEN Center(v, op, clip, pix, Mid, delta) END ELSIF t.value >= Value.Deuce THEN Center(v, op, clip, pix, Point.T{MidH, Row1}, delta); Center(v, op, clip, xip, Point.T{MidH, Row5}, delta); IF t.value >= Value.Three THEN Center(v, op, clip, pix, Mid, delta) END ELSE Center(v, op, clip, CardSuit.AcePix(t.family), Mid, delta) END END PaintCenter; PROCEDURE Center ( v : Card; op : PaintOp.T; READONLY clip : Rect.T; pm : Pixmap.T; READONLY midpt, delta: Point.T ) = VAR dom := VBT.PixmapDomain(v, pm); nw := Point.Sub(Point.Add(delta, midpt), Rect.Middle(dom)); BEGIN VBT.PaintPixmap(v, clip, op, pm, nw) END Center; PROCEDURE BorderCenter ( v : Card; op, top : PaintOp.T; READONLY clip : Rect.T; pm : Pixmap.T; READONLY midpt, delta: Point.T; pix, xip : Pixmap.T; s : Suit; r : FaceCards.FaceRank) = VAR dom := VBT.PixmapDomain(v, pm); nw := Point.Sub(Point.Add(delta, midpt), Rect.Middle(dom)); border: Rect.T; a: Rect.Partition; BEGIN VBT.PaintPixmap(v, clip, op, pm, nw); Center(v, top, clip, pix, FaceCards.PixCenter(s, r), nw); Center(v, top, clip, xip, FaceCards.XipCenter(s, r), nw); dom := Rect.Move(dom, nw); border := Rect.Inset(dom, -1); Rect.Factor(Rect.Meet(clip, border), dom, a, 0, 0); a[2] := a[4]; VBT.PolyTint(v, SUBARRAY(a, 0, 4), op) END BorderCenter; PROCEDURE PaintRankAndSuit (v: Card; t: T; READONLY clip: Rect.T) = VAR op : PaintOp.T; delta := Rect.NorthWest(VBT.Domain(v)); pix : Pixmap.T; BEGIN IF t.family = Family.Hearts OR t.family = Family.Diamonds THEN op := red ELSE op := black END; VBT.PaintPixmap( v, clip, op, CardRank.Pix(t.value), Point.Add(delta, RankNW)); pix := CardRank.Xip(t.value); VBT.PaintPixmap(v, clip, op, pix, Point.Sub(Point.Add(delta, KnarNW), Rect.SouthEast(VBT.PixmapDomain(v, pix)))); IF t.family = Family.Diamonds THEN INC(delta.h) END; VBT.PaintPixmap( v, clip, op, CardSuit.RankPix(t.family), Point.Add(delta, SuitNW)); pix := CardSuit.RankXip(t.family); VBT.PaintPixmap(v, clip, op, pix, Point.Sub(Point.Add(delta, TiusNW), Rect.SouthEast(VBT.PixmapDomain(v, pix)))); END PaintRankAndSuit; PROCEDURE TranslateAndClip (READONLY a : ARRAY OF Rect.T; VAR b : ARRAY OF Rect.T; READONLY delta: Point.T; READONLY clip : Rect.T ) = BEGIN FOR i := FIRST(a) TO LAST(a) DO b[i] := Rect.Meet(clip, Rect.Move(a[i], delta)) END END TranslateAndClip; PROCEDURE PaintTopCorners (v: Card; t: T; READONLY clip: Rect.T) = VAR op1, op2: PaintOp.T; txt : Pixmap.T; bottom := Bottom(t); a1 : ARRAY [0 .. LAST(TopCornerRectsA)] OF Rect.T; a2 : ARRAY [0 .. LAST(TopCornerRectsB)] OF Rect.T; BEGIN IF bottom = t OR NOT Real(t.below) OR bottom.value = Value.Min THEN op1 := felt.op; op2 := felt.op; txt := felt.txt; ELSIF t.below.faceUp THEN op1 := PaintOp.Bg; op2 := PaintOp.Fg; txt := Pixmap.Solid ELSE op1 := back; op2 := PaintOp.Fg; txt := backPix; END; TranslateAndClip( TopCornerRectsA, a1, Rect.NorthWest(VBT.Domain(v)), clip); IF txt = Pixmap.Solid THEN VBT.PolyTint(v, a1, op1) ELSE VBT.PolyTexture(v, a1, op1, txt, Rect.NorthWest(VBT.Domain(t.below))) END; TranslateAndClip( TopCornerRectsB, a2, Rect.NorthWest(VBT.Domain(v)), clip); VBT.PolyTint(v, a2, op2) END PaintTopCorners; PROCEDURE PaintBottomCorners ( v : Card; <*UNUSED*> t : T; READONLY clip: Rect.T ) = VAR a: ARRAY [0 .. LAST(BottomCornerRects)] OF Rect.T; BEGIN TranslateAndClip( BottomCornerRects, a, Rect.NorthWest(VBT.Domain(v)), clip); VBT.PolyTexture(v, a, felt.op, felt.txt) END PaintBottomCorners; PROCEDURE PaintBorder (v: Card; <*UNUSED*>t: T; READONLY clip: Rect.T) = VAR a: ARRAY [0 .. LAST(BorderRects)] OF Rect.T; BEGIN TranslateAndClip(BorderRects, a, Rect.NorthWest(VBT.Domain(v)), clip); VBT.PolyTint(v, a, PaintOp.Fg) END PaintBorder; PROCEDURE PaintBg (v: Card; t: T; READONLY clip: Rect.T) = VAR op : PaintOp.T; txt: Pixmap.T; a : ARRAY [0 .. LAST(BgRects)] OF Rect.T; BEGIN IF NOT Real(t) THEN txt := felt.txt; op := felt.op ELSIF t.faceUp THEN txt := Pixmap.Solid; op := PaintOp.Bg ELSE txt := backPix; op := back END; TranslateAndClip(BgRects, a, Rect.NorthWest(VBT.Domain(v)), clip); VBT.PolyTexture(v, a, op, txt) END PaintBg; PROCEDURE EnableTracking (enable: BOOLEAN) = BEGIN tracking := enable END EnableTracking; PROCEDURE EnableHighlight (enable: BOOLEAN; chain: INTEGER) = BEGIN highlight := enable; chainTime := chain END EnableHighlight; PROCEDURE Shuffle (VAR deck: ARRAY OF T) = VAR j: INTEGER; c: T; BEGIN FOR i := 0 TO LAST(deck) DO j := Random.Subrange(Random.Default, i, LAST(deck)); c := deck[i]; deck[i] := deck[j]; deck[j] := c END END Shuffle; PROCEDURE Top (c: T): T = BEGIN RETURN Bottom(c).below END Top; PROCEDURE Bottom (c: T): T = VAR d := c.below; BEGIN IF NOT Real(c) THEN RETURN c END; WHILE Real(d) AND d # c DO d := d.below END; RETURN d END Bottom; CONST BorderRects = ARRAY OF Rect.T{ Rect.T{4, Width - 4, 0, 1}, Rect.T{4, Width - 4, Height - 1, Height}, Rect.T{0, 1, 4, Height - 4}, Rect.T{Width - 1, Width, 4, Height - 4}, Rect.T{2, 4, 1, 2}, Rect.T{Width - 4, Width - 2, 1, 2}, Rect.T{2, 4, Height - 2, Height - 1}, Rect.T{Width - 4, Width - 2, Height - 2, Height - 1}, Rect.T{1, 2, 2, 4}, Rect.T{1, 2, Height - 4, Height - 2}, Rect.T{Width - 2, Width - 1, 2, 4}, Rect.T{Width - 2, Width - 1, Height - 4, Height - 2}}; BgRects = ARRAY OF Rect.T{ Rect.T{4, Width - 4, 1, 2}, Rect.T{2, Width - 2, 2, 4}, Rect.T{1, Width - 1, 4, Height - 4}, Rect.T{2, Width - 2, Height - 4, Height - 2}, Rect.T{4, Width - 4, Height - 2, Height - 1}}; TopCornerRectsA = ARRAY OF Rect.T{Rect.T{1, 4, 0, 1}, Rect.T{Width - 4, Width - 1, 0, 1}, Rect.T{1, 2, 1, 2}, Rect.T{Width - 2, Width - 1, 1, 2}}; TopCornerRectsB = ARRAY OF Rect.T{ Rect.T{0, 1, 0, 4}, Rect.T{Width - 1, Width, 0, 4}}; BottomCornerRects = ARRAY OF Rect.T{ Rect.T{0, 4, Height - 1, Height}, Rect.T{Width - 4, Width, Height - 1, Height}, Rect.T{0, 2, Height - 2, Height - 1}, Rect.T{Width - 2, Width, Height - 2, Height - 1}, Rect.T{0, 1, Height - 4, Height - 2}, Rect.T{Width - 1, Width, Height - 4, Height - 2}}; BEGIN Random.Start(Random.Default, -1); attachable := NotAttachable; play := NoPlay; obvious := NoMove; trivial := NoMove; stupid := NoMove; felt := TwoTone.New(PaintOp.Pair(PaintOp.Bg, realFelt), Gray.New4x4(6)); END Card.