|
|
|
Reblox - Source CodeChallenging stacking block game. |
|
REBOL [
Title: "REBLOX"
Author: "Allen Kamp"
Email: allen@aussieweb.com.au
Version: 1.0.2
Date: 20-Feb-2002
Purpose: {Fun & Addictive block-matching game}
Thanks: {Thanks to Chris RG for introducing me to this game.
thanks to Robert Condon for help with the scoring system
And thanks to Anop Boonthaveepath for writing the java applet version I played}
History: [2-mar-2004 1.0.2 "Modified for REBOL/Plugin"]
]
reblox: context [
types: reduce [
[color: red text: "R"]
[color: blue text: "E"]
[color: green text: "B"]
[color: pink text: "O"]
[color: orange text: "L"]
]
rows: 10
columns: 20
tiles: rows * columns
tile-size: 30x30
grid-size: to-pair reduce [columns * tile-size/x rows * tile-size/y]
title-height: 28
tface: none
max-type: rows * columns / length? types
if not integer? max-type [alert "max-type must be an integer"]
random/seed now/precise
puzzle: random 30000
;--Game State
locked: off
game-over?: false
last-found: none
tile-set: copy []
selected: copy []
score-table: copy []
patterns: [0x-1 -1x0 1x0 0x1]
to-index: func [rc [pair!]][
either all [rc/x <= rows rc/y <= columns rc/x > 0 rc/y > 0][
return ((rc/y - 1) * rows) + rc/x
][
return none
]
]
make-tile-set: does [
foreach type types [insert/dup tile-set context type max-type]
]
make-score-table: has [s1 s2 s3 table][
s1: 0.0
s2: 2.0
table: copy [0 [0] 1 [0]]
repeat i max-type - 1 [
append table reduce [i + 1 reduce [s3: s1 + s2]]
s1: s2
s2: s3
]
table
]
scores-obj: context [
selected: 0 worth: 0 tally: 0 removals: copy []
]
scores: make scores-obj []
remove-tiles: does [
foreach face selected [
hide-tile face
]
show selected
move-tiles
clear selected
]
sort-cols: func [a b][a/1 < b/1]
move-tiles: has [cols col][
cols: copy []
foreach face selected [
either col: select cols face/rc/2 [
append col face/rc
][
repend cols [face/rc/2 reduce [face/rc]]
]
]
sort/skip cols 2
move-down cols
move-left cols
]
move-down: func [cols /local bottom top][
foreach [col rcs] cols [
sort/compare rcs :sort-cols
bottom: last rcs
top: -1x0 + bottom
top/1: max top/1 1
while [top/1 > 0][
either copy-tile top bottom [
bottom: bottom + -1x0
top: -1x0 + bottom
][top: -1x0 + top]
]
]
]
move-left: func [cols /local face rc rc-from rc-to count][
count: 0
foreach [col rcs] cols [
face: get-tile rc: to-pair reduce [rows col - count]
if not face/text [
count: count + 1
for c rc/2 columns 1 [
repeat r rows [
copy-tile rc-from: to-pair reduce [r c] rc-to: to-pair reduce [r c - 1]
]
]
]
]
]
find-moves: has [face below right match][
;-- last found is still there?
if all [
last-found
last-found/1/text
last-found/2/text
last-found/1/text = last-found/2/text
][return last-found]
;-- search for a new one
moves?: false
repeat r rows [
repeat c columns [
face: get-tile to-pair reduce [r c]
below: get-tile to-pair reduce [r + 1 c]
right: get-tile to-pair reduce [r c + 1]
if any [
if all [face below face/text below/text][if face/text = below/text [match: below]]
if all [face right face/text right/text][if face/text = right/text [match: right]]
][
return reduce [face match]
]
]
]
return none
]
get-tile: func [rc /local index][
index: to-index rc
if index [pick lay/pane index]
]
copy-tile: func [rc-from rc-to][
rc-from: get-tile rc-from
rc-to: get-tile rc-to
if all [rc-from rc-from/text][
rc-to/color: rc-from/color
rc-to/edge: make rc-to/edge [size: 3x3 color: rc-from/color + 30]
set-font rc-to 'color white
rc-to/text: rc-from/text
hide-tile rc-from
true
]
]
hide-tile: func [face][
face/edge: make face/edge [size: 0x0]
face/color: white
set-font face 'color white
face/text: none
]
clear-selected: does [
foreach face selected [
face/edge: make face/edge [size: 3x3]
face/color: face/font/color
set-font face 'color white
]
show selected
clear selected
]
mark-selected: func [face][
set-font face 'color face/color
face/color: white
face/edge: make face/edge [size: 0x0]
append selected face
]
find-same: func [face target /mark /local f][
if all [face face/text = target not find selected face] [
mark-selected face
foreach pattern patterns [
if f: get-tile (face/rc + pattern) [find-same f target]
]
]
]
update-scores: has [value][
tsel/text: scores/selected
twth/text: to-integer scores/worth
tscr/text: join "Score: " to-integer scores/tally
show [tscr twth tsel]
]
click-action: [
if locked [exit]
locked: true
either face/text [
either find selected face [
append scores/removals length? selected
remove-tiles
scores/tally: scores/tally + scores/worth
show lay
if none? last-found: find-moves [
update-scores
game-over?: true
game-msg/show?: true
show game-msg
locked: true
exit
]
][
clear-selected
find-same face face/text
scores/selected: length? selected
scores/worth: first select score-table (scores/selected)
either (1 < length? selected) [show selected][clear-selected]
]
][
clear-selected
scores/selected: 0
scores/worth: 0
]
update-scores
locked: false
]
lay: [
style bx box tile-size :click-action font [size: 14 shadow: none] edge [size: 3x3 effect: 'bevel] with [id: 0 rc: 0x0]
space 0x0 origin 0x0 across
]
lay: layout/size head insert/dup tail lay 'bx (rows * columns) grid-size
make-grid: has [count face][
count: 0
repeat column columns [
repeat row rows [
count: count + 1
face: pick lay/pane count
face/rc: to-pair reduce [row column]
face/offset: to-pair reduce [(column - 1) * tile-size/x (row - 1) * tile-size/y]
face/offset/y: face/offset/y + title-height
face/id: count
]
]
]
make-game-msg: does [
game-msg: layout/offset [
origin 0x0
text font-size 18 bold "GAME OVER" red
] 0x2
game-msg/color: none
game-msg/offset/x: lay/size/x / 2 - (game-msg/size/x / 2)
game-msg/offset/y: 30
append lay/pane game-msg
]
; Add a title area because plugin doesn't have one, and the original script used one
title-face: copy []
add-title: does [
title-face: layout [origin 0x0 space 0x0 at 0x0 tface: label right " " 600x26 white silver effect [emboss gradcol 1x1 140.140.140 100.100.100]
at 1x1 image logo.gif
]
append lay/pane title-face/pane
]
make-score-board: has [req][
score-board: layout [
style text text middle left
origin 0x0 space 0x0
across
at 0x0 box 600x26 silver effect [emboss gradcol 1x1 140.140.140 100.100.100]
at 2x2 btn "New Game" [puzzle: random 30000 new-game]
btn "Replay Game" [new-game]
btn "Select Game" [
if req: request-text/title "Game Puzzle Number?" [
if not error? try [req: to-integer req][puzzle: req new-game]
]
]
btn-help [show-help]
pad 10
text "Selected:" tsel: text "000"
text "Worth:" twth: text "204668310"
tscr: text "Score: 204668310" right bold
]
score-board/size/x: tile-size/x * columns
score-board/size/y: score-board/size/y + 8
score-board/offset/y: title-height + grid-size/y + 2
score-board/offset/x: 0
score-board/edge: make face/edge [size: 3x3 color: silver effect: 'ibevel]
lay/size/y: title-height + lay/size/y + score-board/size/y + 1
]
help-lay: none
show-help: does [
if not help-lay [
help-lay: center-face layout [origin 5x5 backcolor silver
text as-is black ivory - 20 {
Objective: To achieve a high score or Remove all the blocks.
Play: Remove blocks which touch each other either vertically or horizontally.
Controls: Click once to select, and once again to remove blocks.
(If you change your mind, click on another set of blocks to unselect)
Bonus Points: The more blocks selected/removed in one go, the higher the score.
} 450 bold edge [size: 1x1 color: navy]
]
]
unview/only help-lay
view/new help-lay
]
new-game: has [type mixed][
random/seed: puzzle
scores: make scores-obj []
locked: off
game-over?: false
game-msg/show?: false
last-found: none
selected: head clear selected
update-scores
mixed: random copy tile-set
repeat i tiles [
type: mixed/:i
tile: lay/pane/:i
tile/text: copy type/text
tile/color: type/color
tile/edge: make tile/edge [color: type/color + 30 size: 3x3]
set-font tile 'color white
]
lay/text: join " REBLOX - Puzzle " puzzle
tface/text: lay/text
lay/changes: 'text
show lay
]
init: does [
score-table: make-score-table
make-tile-set
make-grid
make-score-board
add-title
make-game-msg
new-game
view/new center-face lay
append lay/pane score-board
show lay
do-events []
]
]
reblox/init
|
