|
|
|
Poker Squares - Source CodeTwo dimensional poker-style card game. |
|
REBOL [
Title: "Poker Squares"
Date: 2-Dec-2000
Author: "Allen Kamp"
Email: allen@aussieweb.com.au
Version: 2.0.4
File: %psquares.r
category: [games view]
Purpose: {A fun card game}
Notes: {Based on the game as described by David Parlett in
Penguin Book of Card Games 1987.}
History: [
2.0.0 [15-Dec-2000 "Rewritten for Link" "Allen K"]
2.0.1 [16-Apr-2001 "Ported to View 1.1" "Allen K"]
2.0.1 [16-May-2001 "Updated Help" "Allen K"]
2.0.3 [15-Nov-2001 "Updated for Link" "Allen K"]
2.0.4 [3-Mar-2004 "Updated for Browser Plugin" "Allen K"]
]
]
rf-view-utils: make object! [
set 'data-download func [url [url!] message [string!]
{Shows a dialog if needed whilst doing a load-thru}
/decompress
/local data-file wait-message
][
either exists-thru? url [
data-file: either decompress [
system/words/decompress load-thru/binary url
][
load-thru/binary url
]
][
wait-message: layout [
size 350x40
backdrop 230.230.204
at 10x10 text (message) black
]
view/new center-face wait-message
data-file: either decompress [
system/words/decompress load-thru/binary url
][
load-thru/binary url
]
unview/only wait-message
]
return data-file
]
] ;--- End Rebolforces View Utils
ctx-ps: context [
get-pane: func [face][copy/deep face/pane]
random/seed now/time
score-method: 1 ;1 English 2 American
total: 0
; do decompress read/binary %cards.bin
do data-download/decompress http://www.rebol.net/plugin/demos/cards.bin
"Downloading Card image File (65k). Please Wait.."
;---------------
; Scoring Data
;---------------
hands: [
[piles [ 1 2 3 4 5] status 0]
[piles [ 6 7 8 9 10] status 0]
[piles [11 12 13 14 15] status 0]
[piles [16 17 18 19 20] status 0]
[piles [21 22 23 24 25] status 0]
[piles [ 1 6 11 16 21] status 0]
[piles [ 2 7 12 17 22] status 0]
[piles [ 3 8 13 18 23] status 0]
[piles [ 4 9 14 19 24] status 0]
[piles [ 5 10 15 20 25] status 0]
]
;----------------
; Score Functions
;----------------
scorehand: func [hand /local card score-id suits ranks][
suits: copy []
ranks: copy []
score-id: 0
foreach id hand [
card: tableau/pane/:id/content/1
append ranks cards/:card/rank
append suits cards/:card/suit
]
sort ranks
either zero? (score-id: pairs? ranks) [
score-id: (flush? suits) + (straight? ranks) + (royal? ranks)
][
score-id
]
]
display: func [score-id index /local description points][
set [description points] get-score score-id
descriptions/pane/:index/text: description
scores/pane/:index/text: points
scores/pane/:index/data: score-id
total/text: total/text + points
show descriptions/pane/:index
show scores/pane/:index total
show total
]
re-score: func [ /local which score-id score tally][
tally: 0
repeat index 10 [
score-id: scores/pane/:index/data
if not none? score-id [
score: second get-score score-id
scores/pane/:index/text: score
show scores/pane/:index
tally: tally + score
]
]
total/text: tally
show total
]
get-score: func [score-id /local description points][
set [description points] switch/default score-id [
20 [["Royal Flush" [30 100]]]
15 [["Straight" [12 15]]] ;ace high straight
12 [["Straight Flush" [30 75]]]
7 [["Straight" [12 15]]] ;normal straight
6 [["Four of Kind" [16 50]]]
5 [["Flush" [5 20 ]]]
4 [["Full House" [10 25]]]
3 [["Three of a Kind" [ 6 10]]]
2 [["Two Pair" [ 3 5]]]
1 [["One Pair" [ 1 2]]]
][ ["Nothing" [ 0 0]]]
reduce [description pick points score-method]
]
process: func [face /local index][
;-if row or column is full, score it
index: face/row
hands/:index/status: hands/:index/status + 1
if hands/:index/status = 5 [
display scorehand hands/:index/piles index
]
index: face/column + 5
hands/:index/status: hands/:index/status + 1
if hands/:index/status = 5 [
display scorehand hands/:index/piles index
]
]
flush?: func [suits][
either (length? (intersect suits suits)) = 1 [5][0]
]
straight?: func [ranks][
either
all [(ranks/2 + 3) = ranks/5
any [(ranks/1 + 4) = ranks/5
(ranks/1 + 12) = ranks/5
]
][
return 7
][
return 0
]
]
royal?: func [ranks][
either all [
ranks/1 = 1
ranks/2 = 10
ranks/3 = 11
ranks/4 = 12
ranks/5 = 13
][8][0]
]
pairs?: func [ranks /local i][
i: 0
If ranks/1 = ranks/2 [i: i + 1]
If ranks/1 = ranks/3 [i: i + 1]
If ranks/1 = ranks/4 [i: i + 1]
If ranks/1 = ranks/5 [i: i + 1]
If ranks/2 = ranks/3 [i: i + 1]
If ranks/2 = ranks/4 [i: i + 1]
If ranks/2 = ranks/5 [i: i + 1]
If ranks/3 = ranks/4 [i: i + 1]
If ranks/3 = ranks/5 [i: i + 1]
If ranks/4 = ranks/5 [i: i + 1]
i
]
;-------------
; New Game
;-------------
get-seed: func [ /local game-seed inactive?][
random/seed now
game-seed: random 32000
;---Catch first time as face is not active yet
if seed/text = "" [inactive?: true]
seed/text: game-seed
if not inactive? [show seed]
return game-seed
]
shuffle: func [pack [block!] /seeded gseed [integer!] /local val size insize][
pack: copy pack
size: length? pack
insize: size + 1
if not seeded [gseed: get-seed]
random/seed gseed
repeat times 3 [
repeat index size [
val: pick pack index
remove at pack index
insert at pack (random insize) val
]
]
return head pack
]
new-pack: func [/local pack][
pack: copy []
repeat index 52 [
append pack index
]
return head pack
]
new-game: func [/seeded gseed][
unfocus
repeat index 26 [
tableau/pane/:index/content: copy [53]
show tableau/pane/:index
]
repeat index 10 [
scores/pane/:index/text: copy ""
scores/pane/:index/data: none
descriptions/pane/:index/text: copy ""
hands/:index/status: 0
show scores/pane/:index
show descriptions/pane/:index
]
;Total Score
total/text: 0
show total
either seeded [
insert deck/content copy/part shuffle/seeded pack gseed 25
][
insert deck/content copy/part shuffle pack 25
]
show deck
]
repeat-game: func [seed][
if not error? try [seed: to-integer seed][new-game/seeded seed]
]
;--------------
; Layout
;-------------
deck: copy []
pile: make face [
offset: 0x0
size: 71x95
image: none
edge: none
effect: [key 0.191.0]
color: none
content: [53]
row: 0
column: 0
feel: make feel [
engage: func [face action event index][
if action = 'down [
if face/id = 26 [new-game exit]
if all [(length? deck/content) > 1 (length? face/content) = 1][
insert face/content first deck/content
remove deck/content
show [face deck]
process face
]
if system/view/focal-face [unfocus]
]
]
redraw: func [face index][
index: first face/content
face/image: cards/:index/image
]
]
]
make-tableau: func [faces [block!] /local index coords tableau][
tableau: make face [
offset: 10x10
size: 610x515
color: 0.128.0
edge: none
pane: copy []
]
index: 0
repeat rows 5 [
repeat columns 5 [
index: index + 1
append tableau/pane make pile [
offset: to-pair reduce [columns - 1 * 75 + 10 rows - 1 * 100 + 10]
ID: index
row: rows
column: columns
]
]
]
;Add Deck
append tableau/pane make pile [offset: 460x110 ID: 26]
deck: tableau/pane/26
insert deck/content copy/part shuffle new-pack 25
append tableau/pane faces
tableau
]
ps: stylize [
gstrip: image 150x20 with [color: 0.100.0 image: none effect: [colorize 0.240.0]]
lgstrip: image with [color: 0.128.0] 58x20 effect [colorize 0.240.0]
]
how-to-play: layout [
style txt text 250 snow
size 610x515
backdrop 0.88.0
at 200x10 vh1 "Poker Squares" gold
at 30x50 vh2 "About" gold
txt {A game of considerable skill. A poker square is an
array of 25 cards in five rows and five columns. Each
row and each column is assessed as a poker hand and given
a score. There are two common scoring methods.}
txt {
1. English (based upon rarity of hands occuring in Poker Squares)
A score of 70 or more is considered a good score}
txt {
2. American (based upon rarity of hands occuring in a normal Poker hand)
A score of 200 or more is considered a good score.}
at 65x300 list [
across space 0x0 style ytext text 255.255.204 right
ytext 100x17 left ytext 22x17 ytext 20x17 ] 170x210 data [
["" "E" "A"]
["Royal Flush" "30" "100"]["Straight Flush" "30" "75"]["Straight" "12" "15"]
["Four of a Kind" "16" "50"]["Flush" "5" "20"]["Full House" "10" "25"]
["Three of a Kind" "6" "10"]["Two Pair" "3" "5"]["One Pair" "1" "2"]
["Nothing" "0" "0"]
] with [color: none edge: none]
at 320x50 vh2 {How to Play} gold
txt {
To place a card, simply click on the desired location in the grid, the top
card of the deck will be placed there and the next card will be revealed on the
top of the deck. Choose placement carefully, cards cannot be moved once they are placed.
As each row or column is completed, it is scored.}
txt {You may change the current scoring method
at any time by clicking on the method beside "Score" it will show either "(English)" or
"(American)" the scores will be recalculated to reflect the current selection.
} 250
txt {To start a new game (at any time) click on the Deck}
txt {Enjoy!}
txt {Allen Kamp allen@aussieweb.com.au}
at 480x480 label "Close" [unview/only how-to-play] 100x20 255.255.255 right
]
replay-tab: make face [
offset: 390x15
size: 60x60
edge: none
color: 0.80.0
pane: get-pane layout [
at 0x10 label "Poker" 60x16 center middle
at 0x30 label "Squares" 60x16 center middle
]
]
replay: make face [
offset: 448x15
size: 150x60
edge: make edge [size: 2x2 color: 0.80.0 effect: none]
color: 0.100.0
pane: get-pane layout [styles ps
at 0x0 gstrip
at 38x0 label "How to Play?" [
unview/only how-to-play view/new/offset/title how-to-play tableau/offset "Poker Squares - Rules"]
80x20 255.255.255 right
at 0x40 gstrip
at 10x20 text "Repeat #" [repeat-game fseed/text] 255.255.205
at 70x20 fseed: field "" 65x20 255.255.205 [repeat-game fseed/text]
at 40x40 text "New Game" [new-game] 255.255.205
]
]
underlay: make face [
offset: 448x240
size: 150x260
edge: make edge [size: 2x2 color: 0.80.0 effect: none]
color: 0.100.0
pane: get-pane layout [
styles ps
space 0x20 at 0x0 gstrip
gstrip gstrip gstrip
gstrip gstrip gstrip
]
]
headings: make face [
offset: 390x240
size: 60x220
edge: none
color: 0.80.0
pane: get-pane layout [
styles ps
style lbl label 50x16
space 0x4 at 10x0
lbl "Row 1"
lbl "Row 2"
lbl "Row 3"
lbl "Row 4"
lbl "Row 5"
at 0x100 lgstrip
at 10x120
lbl "Col 1"
lbl "Col 2"
lbl "Col 3"
lbl "Col 4"
lbl "Col 5"
]
]
descriptions: make face [
offset: 448x242
size: 110x260
image: color: edge: none
pane: get-pane layout [
styles ps
style slbl label "" 100x16 255.255.204
space 0x4 at 10x0
slbl slbl slbl slbl slbl pad 20
slbl slbl slbl slbl slbl
at 2x240 text 70x20 [
score-method: score-method + 1
if score-method = 3 [score-method: 1]
face/text: pick face/texts score-method
show face
re-score
] with [text: "(English)" texts: ["(English)" "(American)"]] white font-size 11
at 70x240 label "Score" 40x16
]
]
scores: make face [
offset: 557x242
size: 45x260
image: color: edge: none
pane: get-pane layout [
style slbl label "" 30x16 255.255.204 right
space 0x4 at 5x0
slbl slbl slbl slbl slbl pad 20
slbl slbl slbl slbl slbl
at 5x240 slbl 255.255.255
]
]
;--Shortcut
total: scores/pane/11
total/text: 0
seed: replay/pane/5
;--init
pack: new-pack
tableau: make-tableau [underlay headings descriptions scores replay replay-tab]
]
;print ctx-ps/tableau/size
view center-face ctx-ps/tableau none
|
