The game is cool and computer play well, if you like backgammon, you should see it:
http://www.tgd-consulting.de/Download.html#BackIt
REBOL [
Title: "Back-It!"
Name: "Back-It!"
File: %BackIt.r
Needs: 'View
Date: 12-Aug-2006
Version: 1.5.1
Author: "Dirk Weyand"
Owner: "Dirk Weyand"
Rights: "TGD-Consulting"
Home: http://www.TGD-Consulting.DE/Download.html
Purpose: "Backgammon-game for REBOL/View"
Comment: {
Back-It! is TGD-Consulting´s Backgammon
style game for REBOL/View.
You can play Back-It! against the computer
or with 2 players against each other.
The purpose of Back-It! is to move your
coins to the in-field & then out of the game.
The player with the highest dice begins.
Have fun and enjoy playing Back-It!}
History: [
{0.1.0 ^-18-Jul-2004 ^-"initial release"^/}
{0.2.0 ^-12-Aug-2004 ^-"added GUI"^/}
{0.3.0 ^-13-Aug-2004 ^-"added computer-logic"^/}
{0.3.1 ^-14-Aug-2004 ^-"changed options"^/}
{0.3.2 ^-15-Aug-2004 ^-"enhanced computer-logic"^/}
{0.3.3 ^-16-Aug-2004 ^-"fixed valid moves"^/}
{0.3.4 ^-17-Aug-2004 ^-"changed coin-layout"^/}
{0.4.0 ^-18-Aug-2004 ^-"internal beta-release"^/}
{0.4.1 ^-19-Aug-2004 ^-"changed score-points"^/}
{0.5.0 ^-20-Aug-2004 ^-"added coin-animation"^/}
{0.5.1 ^-21-Aug-2004 ^-"enabled computer-logic"^/}
{0.5.2 ^-27-Aug-2004 ^-"fixed computer moves"^/}
{0.5.3 ^-28-Aug-2004 ^-"disabled debug output"^/}
{1.0.0 ^-29-Aug-2004 ^-"first public release"^/}
{1.0.1 ^-23-Sep-2004 ^-"fixed move-order change"^/}
{1.0.2 ^-24-Sep-2004 ^-"improved computer-logic"^/}
{1.1.0 ^-25-Sep-2004 ^-"added rookie-mode"^/}
{1.1.1 ^-26-Sep-2004 ^-"fixed computer-time"^/}
{1.2.0 ^-08-Oct-2004 ^-"added dice-pause"^/}
{1.2.1 ^-13-May-2005 ^-"fixed marquees"^/}
{1.3.0 ^-21-Jan-2006 ^-"added REBOL/View check"^/}
{1.4.0 ^-05-Feb-2006 ^-"added ESC-key control"^/}
{1.4.1 ^-29-Jul-2006 ^-"fixed coin-animation"^/}
{1.5.0 ^-30-Jul-2006 ^-"added config-file"^/}
{1.5.1 ^-12-Aug-2006 ^-"fixed to run on MacOS X"^/}
]
License: {(C) TGD-Consulting
End User License Agreement
IMPORTANT. READ CAREFULLY.
This Lisense Agreement (AGREEMENT) is a legal contract between you and TGD-Consulting (TGD) for the limited use of this TGD software product (SOFTWARE), which includes computer software, and, as applicable, associated media, printed materials, and electronic documentation.
This SOFTWARE is licensed, not sold, to you. TGD retains all right, title and interest in and to the SOFTWARE including, without limitation, all intellectual property rights relating to or embodied in the SOFTWARE.
TGD grants you an non-exclusice license to use the SOFTWARE for personal use only. Commercial use requires seperate licensing from TGD. This AGREEMENT is not assignable or transferable without prior written approval of TGD.
The copyright, trademark, and other proprietary rights notices contained in the SOFTWARE may not be removed, altered, or added to in any way. You may not reverse engineer, decompress, decompile, or disassemble the SOFTWARE. You may not redistribute the SOFTWARE without prior written approval of TGD.
The SOFTWARE key that unlocks additional features and components may not be distributed, published, or transferred. Only the registered licensee of the SOFTWARE key may enable or use the additional features and components of this SOFTWARE.
THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, WITHOUT ANY EXPRESS OR IMPLIED WARRANTY OF ANY KIND. IN NO EVENT WILL TGD OR THE AUTHOR OF THE SOFTWARE BE HELD LIABLE FOR ANY DAMAGES ARISING FROM THE USE OF THIS SOFTWARE.
You agree to use the SOFTWARE in compliance with all applicable laws and regulations including all laws governing the export or re-export of the SOFTWARE. You agree to indemnify TGD from and against your violation of any such laws or regulations.
This AGREEMENT contains the entire agreement between the parties with respect to the license of the SOFTWARE. This AGREEMENT supercedes any prior license agreement of the SOFTWARE.
By installing or using the SOFTWARE, you are consenting to be bound by and are becoming a party to this AGREEMENT. IF YOU DO NOT AGREE TO ALL OF THE TERMS OF THIS AGREEMENT, DO NOT INSTALL OR USE THE SOFTWARE.}
]
if not all [value? 'view? view?] [
until [
print "^L^/Back-It! requires REBOL/View !!!^/"
wait 0.15
print "^L^/^/"
not none? wait [system/ports/input 0.15]
]
quit
]
view: func do head insert find mold third :view "/new" {/kf "Keeps feel of window face"
} do head replace mold second :view "view-face/feel: window-feel" {if not kf [view-face/feel: system/view/window-feel]}
bg-color: (silver - 50)
blau: 122.154.198
debug: false
debug-level: 1
idle: hint: animate: animate-dice: true
lic-read: computer2move: hidereq: hideall: game-started: gewürfelt: erster-wurf: ulf: rookie: false
züge: copy []
moves: copy []
spielstand: [[name "Your name" time 0] [name "Computer" time 0]]
spieler: 1
min-spieler: 1
max-spieler: 2
spieleranzahl: 1
last-time: now/time
gridsize: 320x460
default: [0x0 30x0 15x60 0x0]
ratio-x: divide first gridsize (30 * 6)
ratio-y: divide second gridsize (60 * 2 + 20)
breite: to integer! multiply 30 ratio-x
speed: 0.5
MacOSX: all [equal? fourth system/version 2 equal? fifth system/version 4]
accel: not MacOSX
btn-styles: stylize [
silver-btn: button center middle no-wrap edge [color: bg-color] effects compose/deep [[gradient 0x1 (bg-color + 30) (bg-color - 30)] [gradient 0x-1 (bg-color + 30) (bg-color - 30)]]
sky-btn: button edge [color: blau] effects [[gradient 0x1 164.200.255 90.118.152] [gradient 0x-1 160.200.240 80.108.142]] font [colors: [255.255.255 28.52.86]]
txt-bevel: text 100x20 no-wrap center middle edge [color: bg-color size: 1x1 effect: 'ibevel] with [feel: none]
wtxt-bevel: text 150 middle edge [color: bg-color size: 1x1 effect: 'ibevel] black (bg-color + 100) with [feel: none]
]
spielfeld: make object! [
spieler1: copy [[] [] [] [] [] [c11 c12 c13 c14 c15] [] [c8 c9 c10] [] [] [] [] [c7 c6 c5 c4 c3] [] [] [] [] [] [] [] [] [] [] [c2 c1]]
spieler2: copy [[p1 p2] [] [] [] [] [] [] [] [] [] [] [p3 p4 p5 p6 p7] [] [] [] [] [p10 p9 p8] [] [p15 p14 p13 p12 p11] [] [] [] [] []]
bar1: copy []
bar2: copy []
out1: copy []
out2: copy []
in1: false
in2: false
]
copydate: copy find/tail second system/script/Header/History "^-"
clear find copydate " "
copydate: to date! copydate
either greater? now/year copydate/year [copydate: join form copydate/year ["-" now/year]] [copydate: form copydate/year]
either found? suffix: find/last system/script/Header/File "." [filename: copy/part system/script/Header/File subtract length? system/script/Header/File length? suffix ] [filename: copy system/script/Header/File ]
config-file: join filename ".config"
highscore-path: join filename "-highscores.r"
highscores: either exists? highscore-path [load highscore-path] [
[[name "T G D " points " 0" time "1:00:01" date "18-Jul-2004"]]
]
message: func [
"Display a message window"
str [string! block! object!] "Message to display"
/offset xy [pair!] "Offset of window"
/color colors [tuple! block!] "Used colors"
/timeout time
/local lay result hdl msg c1 c2 c3 f x-hdl x-txt x-p
] [
lay: either all [object? str in str 'type str/type = 'face]
[str] [
c1: green c2: c3: black
hdl: "N O T E :"
if color [either block? colors [set [c1 c2 c3] colors] [c1: colors]]
either block? str [
str: reduce str
set [hdl msg] str
str: reform next next str
foreach n [hdl msg str] [
if all [found? get n not string? get n] [set n form get n]
]
] [
msg: str
str: ""
]
f: layout [h1 copy hdl c1 center middle edge [color: bg-color size: 1x1 effect: 'bevel]]
x-hdl: 20 - 44 + first f/size
either empty? str
[f: layout [across text bold copy msg c2 middle]]
[f: layout [across text bold copy msg c2 middle text copy str c3 middle]]
x-txt: subtract first f/size 44
either greater? x-txt x-hdl [x-p: to integer! (x-txt - x-hdl / 2)] [x-p: 0]
result: copy [
styles btn-styles
backdrop bg-color
across
pad x-p
silver-btn x-hdl copy hdl font [size: 20 colors: compose [(c1) (c1 - 40)]] edge [size: 1x1] [result: true hide-popup] [result: true hide-popup] return
text bold copy msg c2 middle with [feel: none]
]
if not empty? str [insert tail result [text copy str c3 middle with [feel: none]]]
layout result
]
result: none
either offset [inform/offset/timeout lay xy time] [inform/timeout lay time]
result
]
scroll-slider-text: func [tf sf /local tmp size sms] [
if none? tf/para [exit]
size: size-text tf
sms: subtract sf/size 2 * sf/edge/size
tmp: min 0x0 tf/size - size - 0x8
either sf/size/x > sf/size/y [
tf/para/scroll/x: sf/data * first tmp
either any [system/version > 1.3.0 equal? system/product 'Link] [sf/pane/1/size/x: max 10 to integer! divide sms/x max 1 (first size) / tf/size/x ] [sf/pane/size/x: max 10 to integer! divide sms/x max 1 (first size) / tf/size/x ]
] [
tf/para/scroll/y: sf/data * second tmp
either any [system/version > 1.3.0 equal? system/product 'Link] [sf/pane/1/size/y: max 10 to integer! divide sms/y max 1 (second size) / tf/size/y ] [sf/pane/size/y: max 10 to integer! divide sms/y max 1 (second size) / tf/size/y ]
]
sf/state: -1
show [tf sf]
]
scroll-smooth: func [dx tf sf /init /local d] [
d: divide 2 max sf/size/x sf/size/y
either positive? dx [
while [all [lesser? sf/data 1 positive? dx]] [
sf/data: min 1 sf/data + d
dx: subtract dx d
scroll-slider-text tf sf
]
] [
while [all [positive? sf/data 1 negative? dx]] [
sf/data: max 0 sf/data - d
dx: add dx d
scroll-slider-text tf sf
]
]
if init [tf/para/scroll: 0x0]
]
scroll-wheel: func [page n tf sf /init /end] [
either init [
either end [
scroll-smooth/init (n * (either page [tf/size/y] [tf/font/size])) tf sf
] [
scroll-smooth/init divide (n * (either page [tf/size/y] [tf/font/size])) max 1 second size-text tf tf sf
]
if all [not lic-read greater? sf/data 0.97] [lic-read: true]
] [
either end [
scroll-smooth (n * (either page [tf/size/y] [tf/font/size])) tf sf
] [
scroll-smooth divide (n * (either page [tf/size/y] [tf/font/size])) max 1 second size-text tf tf sf
]
]
]
scroll-area: func [page n af /local d size] [
if none? af/para [exit]
size: size-text af
d: (n * (either page [af/size/y] [af/font/size]))
either positive? d [
while [all [positive? add size/y - af/size/y + 8 af/para/scroll/y positive? d]] [
d: subtract d 2
af/para/scroll/y: max subtract af/para/scroll/y 2 negate size/y - af/size/y + 8
show af
]
] [
while [all [negative? af/para/scroll/y negative? d]] [
d: add d 2
af/para/scroll/y: min add af/para/scroll/y 2 0
show af
]
]
]
license-agreement: layout [
styles btn-styles
backdrop bg-color effect reduce ['grid 8x8 (bg-color - 10)]
across
banner join system/script/header/Name " - E U L A" 416 with [feel: none]
return
space 0
f-txt: text 400x150 black ivory edge [color: (bg-color - 25) size: 2x2 effect: 'ibevel] with [feel: none]
f-sld: slider f-txt/size/y * 0x1 + 16x0 edge [color: (bg-color - 25)] [scroll-slider-text f-txt f-sld f-txt/para/scroll: 0x0 if greater? face/data 0.97 [lic-read: true]] return
pad 1x10 return
silver-btn 80 "ACCEPT" "ACCEPTED" keycode [#"^M"] [either lic-read [unview license-agreement] [message/timeout {Read the complete EULA before you accept the agreement !!!} 0:00:06 hide-popup]] [either lic-read [unview license-agreement] [message/timeout {Read the complete EULA, before you accept the agreement!!!} 0:00:06 hide-popup]]
pad 256
silver-btn 80 "Cancel" "Canceld" keycode [#"^["] [unview/all quit] [unview/all quit]
key keycode [up page-up] [scroll-wheel/init true -1 f-txt f-sld]
key keycode [down page-down] [scroll-wheel/init true 1 f-txt f-sld]
key keycode [home] [scroll-wheel/init/end true -1 f-txt f-sld]
key keycode [end] [if lic-read [scroll-wheel/init/end true 1 f-txt f-sld]]
]
insert find/tail system/script/header/license "(C)" join " " copydate
f-txt/text: copy system/script/header/license
license-agreement/feel: make license-agreement/feel [
detect: func [face event /local rc] [
rc: true
switch event/type [
scroll-line [scroll-wheel/init false event/offset/y f-txt f-sld]
scroll-page [scroll-wheel/init true event/offset/y f-txt f-sld]
key [if found? face: find-key-face face event/key [
if get in face 'action [do-face face event/key]
rc: false
]
]
close [quit]
]
if rc [event]
]
]
m: 0
either exists? join filename ".license" [
either all [not error? try [do load join filename ".license" ulf: false] value? 'expiry value? 'license-key value? 'licensee] [
either date? expiry [
either greater? now/date expiry [
m: 3
] [
either equal? license-key checksum/key read system/options/script join system/script/Header/Name [user-prefs/name expiry licensee] [ulf: true ] [m: 2 ]
]
] [
either equal? license-key checksum/key read system/options/script join system/script/Header/Name [user-prefs/name licensee] [ulf: true ] [m: 2 ]
]
] [m: 2 ]
] [m: 1 ]
if any [not ulf not exists? highscore-path] [
scroll-slider-text f-txt f-sld
view/kf center-face license-agreement
]
switch m [
1 [message/color reduce [" A T T E N T I O N : " reform [system/script/Header/Name "license-file not found !!!"] reform ["Please contact" system/script/Header/Rights "& purchase a license."]] yellow
]
2 [message/color reduce [" A T T E N T I O N : " reform ["Your" system/script/Header/Name "license-key is not valid !!!"] reform ["Please contact" system/script/Header/Rights "to get a new license-file."]] yellow
]
3 [message/color reduce [" A T T E N T I O N : " reform ["Your" system/script/Header/Name "license-key is expired !!!"] reform ["Please contact" system/script/Header/Rights "to get a new license-file."]] yellow
]
]
if exists? config-file [
if not error? try [set [myspeed myanimate myaccel myhint] read/direct/lines config-file] [
if found? myspeed [error? try [speed: to decimal! myspeed]]
if found? myanimate [error? try [animate: to logic! do myanimate]]
if found? myaccel [error? try [accel: to logic! myaccel]]
if found? myhint [error? try [hint: to logic! myhint]]
]
]
shutdown: func ["Exits the programm." ] [
write config-file reduce [speed newline animate newline accel newline hint newline]
unview/all
either debug [halt] [quit]
]
update-file: func [data] [
set [path file] split-path highscore-path
if not exists? path [make-dir/deep path]
write highscore-path data
]
save-file: has [buf] [
buf: reform ["REBOL [Title:" mold join system/script/Header/Name " Highscore" "Date:" now "]^/[^/"]
foreach n highscores [repend buf [mold n newline]]
update-file append buf "]"
]
init-highscore: has [i date rank time points] [
clear scorelist/text
i: 1
rank: " "
append scorelist/text {TOP-20
Name Points Time Date
------------------------------------------------------}
foreach element highscores [
append scorelist/text newline
clear rank
if i < 10 [append rank 0]
append rank i
append rank ". "
points: select element 'points
while [3 > length? points] [insert points " "]
time: select element 'time
while [7 > length? time] [append time " "]
date: select element 'date
while [11 > length? date] [insert date " "]
append scorelist/text reform [rank " " select element 'name " " points " " time " (" date ")"]
i: i + 1
]
date: to string! now/date
while [11 > length? date] [insert date " "]
for i (1 + length? highscores) 20 1 [
clear rank
if i < 10 [append rank 0]
append rank i
append rank ". "
append scorelist/text newline
append scorelist/text reform [rank " " "--- " " " "---" " " "-------" " (" date ")"]
]
append scorelist/text newline
append scorelist/text {------------------------------------------------------}
show scorelist
]
update-highscore: func [
"Update highscore"
myname [string!] "The name of the player"
mypoints [integer!] "The number of coins on the playfield"
mytime [time!] "The playing-time"
/local index
] [
while [14 < length? myname] [remove at myname length? myname]
while [14 > length? myname] [append myname " "]
index: 1
foreach element highscores [
either mypoints > to integer! trim select element 'points [
insert at highscores index to block! mold reduce ['name myname 'points form mypoints 'time form mytime 'date form now/date]
break
] [
if all [(equal? mypoints to integer! trim select element 'points) (mytime < to time! trim select element 'time)] [
insert at highscores index to block! mold reduce ['name myname 'points form mypoints 'time form mytime 'date form now/date]
break
]
]
index: index + 1
]
while [20 < length? highscores] [remove at highscores length? highscores]
init-highscore
]
highscore: layout [
styles btn-styles
backdrop effect [gradient 0x1 164.200.255 80.108.142]
across
pad 45 h1 underline "Highscores" 28.52.86 with [feel: none]
pad 110 sky-btn "Close" "Closed" 90 keycode [#"^["] [unview/only highscore] [message/timeout "Press left mouse-button to close window !!!" 0:00:06 hide-popup]
return
space 0
box 405x3 edge [size: 1x1 color: sky effect: 'bevel] return
scorelist: code 28.52.86 center bold 405x100 " " no-wrap rate 25 para [origin: 0x20]
feel [engage: func [face action event] [
if action = 'time [face/para/origin: face/para/origin - 0x1
if lesser? second face/para/origin negate second size-text scorelist [face/para/origin: 0x99]
show face]
]
] return
space 8
box 405x3 edge [size: 1x1 color: sky effect: 'bevel] return
]
init-highscore
history: layout [
styles btn-styles
backdrop bg-color
across
pad 30
banner "History" 90 with [feel: none]
pad 70
silver-btn "Close" "Closed" 90 keycode [#"^["] [unview/only history] [message/timeout "Press left mouse-button to close window !!!" 0:00:06 hide-popup]
return
h-txt: text 274x80 black ivory no-wrap edge [color: bg-color size: 2x2 effect: 'ibevel] with [feel: none]
pad -8x0 h-sld: slider h-txt/size/y * 0x1 + 16x0 edge [color: bg-color] [scroll-slider-text h-txt h-sld]
at 0x0
key keycode [up page-up] [scroll-wheel true -1 h-txt h-sld]
key keycode [down page-down] [scroll-wheel true 1 h-txt h-sld]
key keycode [home] [scroll-wheel/end true -1 h-txt h-sld]
key keycode [end] [scroll-wheel/end true 1 h-txt h-sld]
]
h-txt/text: system/script/header/History
scroll-slider-text h-txt h-sld
history/feel: make history/feel [
detect: func [face event /local rc] [
rc: true
switch event/type [
scroll-line [scroll-wheel false event/offset/y h-txt h-sld]
scroll-page [scroll-wheel true event/offset/y h-txt h-sld]
key [if found? face: find-key-face face event/key [
if get in face 'action [do-face face event/key]
rc: false
]
]
]
if rc [event]
]
]
option: layout [
styles btn-styles
backdrop bg-color
across
banner "Options" 120 with [feel: none]
space 2
silver-btn "?" 28 [ohelp/offset: option/offset + 170x45 view/new/options ohelp [no-title]] [message/timeout "Press left mouse-button to view help !!!" 0:00:06 hide-popup]
silver-btn "Close" "Closed" 70 keycode [#"^["] [unview/only option] [message/timeout "Press left mouse-button to close window !!!" 0:00:06 hide-popup]
return
space 18
box 250x3 edge [size: 1x1 color: bg-color effect: 'bevel] return
space 8
pad 20 txt-bevel "max. players"
space 0
arrow left keycode [down] bg-color edge [color: bg-color] [
if greater? spieleranzahl min-spieler [
spieleranzahl: spieleranzahl - 1
poke spielstand 2 reduce ['name "Computer" 'moves 0 'time 0]
]
txt-sa/text: txt-sa2/text: form spieleranzahl
show [txt-sa txt-sa2]]
txt-sa2: txt-bevel form spieleranzahl 20x20 black ivory
space 8
arrow right keycode [up] bg-color edge [color: bg-color] [
if lesser? spieleranzahl max-spieler [
spieleranzahl: spieleranzahl + 1
poke spielstand 2 reduce ['name join "Player" spieleranzahl 'moves 0 'time 0]
]
txt-sa/text: txt-sa2/text: form spieleranzahl
show [txt-sa txt-sa2]] return
pad 20 txt-bevel "hide-request"
o-hr2: check hidereq ivory 20x20 edge [color: bg-color] [hidereq: o-hr/data: face/data show o-hr] return
pad 20 txt-bevel "hide-all"
check hideall ivory 20x20 edge [color: bg-color] [hideall: face/data] return
pad 20 txt-bevel "animate coins"
check animate ivory 20x20 edge [color: bg-color] [animate: face/data] return
pad 20 txt-bevel "accelerate"
check accel ivory 20x20 edge [color: bg-color] [accel: face/data] return
pad 20 txt-bevel "speed"
space 0
arrow left keycode [left] bg-color edge [color: bg-color] [
speed: sld/data: maximum 0 sld/data - 0.01
show [sld]
]
sld: slider 60x20 edge [color: bg-color size: 1x1] [speed: face/data]
space 8
arrow right keycode [right] bg-color edge [color: bg-color] [
speed: sld/data: minimum 1 sld/data + 0.01
show [sld]
] return
pad 20 txt-bevel "hint"
check hint ivory 20x20 edge [color: bg-color] [hint: face/data] return
pad 20 txt-bevel "rookie-mode"
space 18
check rookie ivory 20x20 edge [color: bg-color] [rookie: face/data] return
box 250x3 edge [size: 1x1 color: bg-color effect: 'bevel] return
]
sld/data: speed
ohelp: layout [
styles btn-styles
backdrop bg-color
across
pad 10 banner "Options-Help" 160 no-wrap with [feel: none]
pad 20
space 2
silver-btn "Close" "Closed" 70 keycode [#"^["] [unview/only ohelp] [message/timeout "Press left mouse-button to close window !!!" 0:00:06 hide-popup]
return
space 18
box 280x3 edge [size: 1x1 color: bg-color effect: 'bevel] return
space 8
pad 10 txt-bevel "max. players"
space 18 wtxt-bevel {Specifies the number of players (Default: 1, you play against the computer).}
return
space 8
pad 10 txt-bevel "hide-request"
space 18 wtxt-bevel "If set, no note for a players-change is displayed."
return
space 8
pad 10 txt-bevel "hide-all"
space 18 wtxt-bevel "If set, no notes or messages are displayed at all."
return
space 8
pad 10 txt-bevel "animate coins"
space 18 wtxt-bevel "If set, the movement of the coins is animated."
return
space 8
pad 10 txt-bevel "accelerate"
space 18 wtxt-bevel "Enables the hardware acceleration for the coins."
return
space 8
pad 10 txt-bevel "speed"
space 18 wtxt-bevel {Sets the speed for the movement of the coins [<<slow<->fast>>].}
return
space 8
pad 10 txt-bevel "hint"
space 18 wtxt-bevel "If set, valid coins are ligthened/darkened."
return
space 8
pad 10 txt-bevel "rookie-mode"
space 18 wtxt-bevel "If set, the computer plays as a rookie."
return
space 8
box 280x3 edge [size: 1x1 color: bg-color effect: 'bevel] return
]
sendmail: layout [
styles btn-styles
backdrop bg-color effect reduce ['grid 8x8 bg-color - 10]
h2 (bg-color - 80) reform ["Send email to" system/script/header/Name "author:"] with [feel: none]
msg: area "Type your message here ..." 250x50 wrap
across return
silver-btn 80 "Send" "Send ..." [
sending: flash "Sending ..."
either error? try [
hdr: make system/standard/email [subject: reform [system/script/header/Name system/script/header/Version "(" user-prefs/name ")"]]
send/header D.Weyand@TGD-Consulting.de msg/text hdr
] [
unview/only sending
message/color ["E R R O R :" "Error sending email !!!" "Check your REBOL network setup."] red
] [
unview/only sending
message/color/timeout ["O K A Y" "Your email has been sent!" "Thanx 4 Your message."] green 0:00:06
hide-popup
unview/only sendmail
]
]
pad 80 silver-btn 80 "Cancel" "Canceled" keycode [#"^["] [unview/only sendmail]
]
sendmail/feel: make sendmail/feel [
detect: func [face event /local rc] [
rc: true
switch event/type [
scroll-line [scroll-area false event/offset/y msg]
scroll-page [scroll-area true event/offset/y msg]
key [if found? face: find-key-face face event/key [
if get in face 'action [do-face face event/key]
rc: false
]
]
]
if rc [event]
]
]
about: layout [
styles btn-styles
backdrop effect [gradient 0x1 164.200.255 80.108.142]
style link text bold font [colors: [0.0.0 28.52.86]]
across
hd1: h1 underline form system/script/header/Name 28.52.86 with [feel: none]
hd2: h1 reform ["Version:" system/script/header/Version] 28.52.86 with [feel: none] return
space 0
box 250x3 edge [size: 1x1 color: sky effect: 'bevel] return
credits: text 28.52.86 center bold 250x80 no-wrap rate 25 para [origin: 0x10]
feel [engage: func [face action event] [
if action = 'time [face/para/origin: face/para/origin - 0x1
if lesser? second face/para/origin negate second size-text credits [face/para/origin: 0x70]
show face]
]
] return
space 8
box 250x3 edge [size: 1x1 color: sky effect: 'bevel] return
space 0
pad 20 text bold "written by" with [feel: none]
link 28.30.50 system/script/header/Author [sendmail/offset: about/offset + 145x165 view/kf/new/options sendmail [no-title]] return
pad 20 text bold reform ["Copyright" copydate ","] with [feel: none]
space 8 link 28.30.50 system/script/header/Rights [
if request ["Connect to homepage of TGD-Consulting ?" "Browse" "Cancel"] [
error? try [browse system/script/header/Home]
]
] return
pad 20 text bold reform ["Updated: " modified? system/options/script] with [feel: none] return
pad 5
sky-btn 75 "Close" "Closed" keycode [#"^["] [unview/only about] [message/timeout "Press left mouse-button to close window !!!" 0:00:06 hide-popup]
sky-btn 75 "Options" "Change" [view/new/options center-face option [no-title]]
sky-btn 75 "History" "Show me" [view/kf/new/options center-face history [no-title]] [message/timeout "Press left mouse-button to view history !!!" 0:00:06 hide-popup]
]
credits/text: {
\|/
@ @
----------oOO-(_)-OOo----------
-= T G D =-
is proud to
present
}
append credits/text reform [">>> " system/script/Header/Name " <<<" newline]
append credits/text form system/script/header/Comment
append credits/text {
- - - - - -
}
either ulf [
append credits/text reform ["This software is registered to" newline licensee "."]
if date? expiry [
append credits/text reform [newline "Your license will expire at" newline expiry "!"]
]
] [
either all [value? 'expiry date? expiry] [
append credits/text reform ["This software has been registered to" newline licensee "," newline "but your license expired !" newline]
] [
append credits/text {This software is not registered yet,
it runs in D E M O - mode only!
}
]
append credits/text reform ["^/If you want to use" system/script/Header/Name {
without limitations,
contact TGD-Consulting by below
links or send an e-mail to:
info@TGD-Consulting.de}]
]
append credits/text "^/^/- - - - - -"
main: layout [
styles btn-styles
backdrop bg-color effect reduce ['grid 8x8 bg-color - 10]
vh1 325 (bg-color + 80) system/script/header/Name with [feel: none]
pad 0x8 panel 325x280 (bg-color + 20) edge [color: bg-color - 20 size: 2x2 effect: 'bevel] [
guide 20x20
at 20x20
panel 280x202 edge [color: bg-color - 20 size: 1x1 effect: 'ibevel] [
origin 0x0
panel 278x200 (bg-color + 20) edge [color: bg-color - 20 size: 1x1 effect: 'bevel] [
across
origin 22x16
at 22x16
h1 230 "Main-Options" center (bg-color - 50) font [colors: compose [(bg-color - 50) (bg-color + 50)]] [ohelp/offset: main/offset + 182x128 view/new/options ohelp [no-title]] [message/timeout "Press left mouse-button to view help !!!" 0:00:06 hide-popup] return
pad 1x1 return
space 18
box 230x3 edge [size: 1x1 color: bg-color effect: 'bevel] return
space 8
pad 30 txt-bevel "max. players"
space 0
arrow left keycode [left down] (bg-color + 20) edge [color: bg-color] [
if greater? spieleranzahl min-spieler [
spieleranzahl: spieleranzahl - 1
poke spielstand 2 reduce ['name "Computer" 'moves 0 'time 0]
]
either value? 'txt-sa2 [txt-sa/text: txt-sa2/text: form spieleranzahl show [txt-sa txt-sa2]]
[txt-sa/text: form spieleranzahl show txt-sa]
]
txt-sa: txt-bevel form spieleranzahl 20x20 black ivory
space 8
arrow right keycode [right up] (bg-color + 20) edge [color: bg-color] [
if lesser? spieleranzahl max-spieler [
spieleranzahl: spieleranzahl + 1
poke spielstand 2 reduce ['name join "Player" spieleranzahl 'moves 0 'time 0]
]
either value? 'txt-sa2 [txt-sa/text: txt-sa2/text: form spieleranzahl show [txt-sa txt-sa2]]
[txt-sa/text: form spieleranzahl show txt-sa]
] return
space 8
pad 30 txt-bevel "hide-request"
space 18
o-hr: check hidereq ivory 20x20 edge [color: bg-color] [hidereq: o-hr2/data: face/data show o-hr2] return
space 12
box 230x3 edge [size: 1x1 color: bg-color effect: 'bevel] return
pad 65 silver-btn 100x30 "S T A R T" ":-)" font [size: 20] [
if not game-started [
spieler: 1
spielername/text: select first spielstand 'name
focus spielername
time/text: copy "0:00:00"
spielstand/2/4: 0
gewürfelt: erster-wurf: false
init-coins
]
view/new/options center-face board [no-title]
]
]]
across
pad 1x6 silver-btn 80 "Highscore" ":-)" [view/new/options center-face highscore [no-title]]
pad 20 silver-btn 60 "Quit" "Bye !" keycode [#"^["] [if confirm reform ["Do you really want to quit" system/script/header/Name "?"] [unview/all ]]
pad 20 silver-btn 80 "About" "Show Me" [
xsize: to integer! ((first about/size - (first hd2/offset + first hd2/size - first hd1/offset)) / 2)
hd2/offset: to pair! join xsize + first hd2/offset - first hd1/offset ["x" second hd2/offset]
hd1/offset: to pair! join xsize ["x" second hd1/offset]
show [hd1 hd2]
view/new/options center-face about [no-title]] return
]
]
main/feel: make main/feel [
detect: func [face event /local rc] [
rc: true
switch event/type [
key [if found? face: find-key-face face event/key [
if get in face 'action [do-face face event/key]
rc: false
]
]
close [rc: false
either confirm reform ["Do you really want to quit" system/script/title "?"] [shutdown] [view/new/kf main]]
]
if rc [event]
]
]
init-coins: func [{Setzt die Offsets der Spielsteine auf Ausgangsposition & initialsiert das Spielfeld.} ] [
c1/offset: 696x26 c1/effect: [fit key 0.0.0 colorize 255.255.255]
c2/offset: 696x66 c2/effect: [fit key 0.0.0 colorize 255.255.255]
c3/offset: 32x26 c3/effect: [fit key 0.0.0 colorize 255.255.255]
c4/offset: 32x66 c4/effect: [fit key 0.0.0 colorize 255.255.255]
c5/offset: 32x106 c5/effect: [fit key 0.0.0 colorize 255.255.255]
c6/offset: 32x146 c6/effect: [fit key 0.0.0 colorize 255.255.255]
c7/offset: 32x186 c7/effect: [fit key 0.0.0 colorize 255.255.255]
c8/offset: 244x364 c8/effect: [fit key 0.0.0 colorize 255.255.255]
c9/offset: 244x404 c9/effect: [fit key 0.0.0 colorize 255.255.255]
c10/offset: 244x444 c10/effect: [fit key 0.0.0 colorize 255.255.255]
c11/offset: 431x284 c11/effect: [fit key 0.0.0 colorize 255.255.255]
c12/offset: 431x324 c12/effect: [fit key 0.0.0 colorize 255.255.255]
c13/offset: 431x364 c13/effect: [fit key 0.0.0 colorize 255.255.255]
c14/offset: 431x404 c14/effect: [fit key 0.0.0 colorize 255.255.255]
c15/offset: 431x444 c15/effect: [fit key 0.0.0 colorize 255.255.255]
p1/offset: 696x404 p1/effect: [fit key 0.0.0 colorize 80.80.80]
p2/offset: 696x444 p2/effect: [fit key 0.0.0 colorize 80.80.80]
p3/offset: 32x284 p3/effect: [fit key 0.0.0 colorize 80.80.80]
p4/offset: 32x324 p4/effect: [fit key 0.0.0 colorize 80.80.80]
p5/offset: 32x364 p5/effect: [fit key 0.0.0 colorize 80.80.80]
p6/offset: 32x404 p6/effect: [fit key 0.0.0 colorize 80.80.80]
p7/offset: 32x444 p7/effect: [fit key 0.0.0 colorize 80.80.80]
p8/offset: 244x26 p8/effect: [fit key 0.0.0 colorize 80.80.80]
p9/offset: 244x66 p9/effect: [fit key 0.0.0 colorize 80.80.80]
p10/offset: 244x106 p10/effect: [fit key 0.0.0 colorize 80.80.80]
p11/offset: 431x26 p11/effect: [fit key 0.0.0 colorize 80.80.80]
p12/offset: 431x66 p12/effect: [fit key 0.0.0 colorize 80.80.80]
p13/offset: 431x106 p13/effect: [fit key 0.0.0 colorize 80.80.80]
p14/offset: 431x146 p14/effect: [fit key 0.0.0 colorize 80.80.80]
p15/offset: 431x186 p15/effect: [fit key 0.0.0 colorize 80.80.80]
spielfeld/spieler1: copy/deep [[] [] [] [] [] [c11 c12 c13 c14 c15] [] [c8 c9 c10] [] [] [] [] [c7 c6 c5 c4 c3] [] [] [] [] [] [] [] [] [] [] [c2 c1]]
spielfeld/spieler2: copy/deep [[p1 p2] [] [] [] [] [] [] [] [] [] [] [p3 p4 p5 p6 p7] [] [] [] [] [p10 p9 p8] [] [p15 p14 p13 p12 p11] [] [] [] [] []]
clear spielfeld/bar1
clear spielfeld/bar2
clear spielfeld/out1
clear spielfeld/out2
spielfeld/in1: false
spielfeld/in2: false
]
last-pos?: func [
{Ermittelt den Most-Valued-Spielstein (letzte Position) des Spieler1.}
/local rc i
] [
rc: none
either empty? spielfeld/bar1 [
for i length? spielfeld/spieler1 1 -1 [
if not empty? pick spielfeld/spieler1 i [rc: i break]
]
] [rc: 25 ]
return rc
]
safe?: func [
{Ermittelt ob die Spielsteine des Computers sicher sind.}
/local rc i
] [
rc: true
either empty? spielfeld/bar1 [
for i 1 last-pos? 1 [
if not empty? pick spielfeld/spieler2 i [rc: false break]
]
] [rc: false ]
return rc
]
priorize-moves: func [
"Safe Moves erhalten niedrigere Priorität."
mymoves [block!] "Zu priorisierende Moves."
/local rc i lo element
] [
rc: copy []
lo: copy []
for i length? mymoves 1 -1 [
either lesser? element: pick mymoves i last-pos? [insert rc element] [insert lo element]
]
insert tail rc lo
return head rc
]
points?: func [
"Ermittelt die Punkte für das gewonnene Spiel."
/computer "Für 2.Spieler überprüfen."
/local rc i
] [
rc: 0
either computer [
i: 1
rc: rc + multiply length? spielfeld/bar1 25
foreach element spielfeld/spieler1 [
rc: rc + multiply length? element i
i: i + 1
]
] [
i: 24
rc: rc + multiply length? spielfeld/bar2 25
foreach element spielfeld/spieler2 [
rc: rc + multiply length? element i
i: i - 1
]
]
return rc
]
ausspielen?: func [
{Überprüft ob ein Spieler sein In-Field komplett mit den eigenen Spielsteinen besetzt hat.}
/computer "Für 2.Spieler überprüfen."
/local rc summe
] [
rc: false
summe: 0
either computer [
foreach i [19 20 21 22 23 24] [summe: summe + length? pick spielfeld/spieler2 i ]
summe: summe + length? spielfeld/out2
] [
foreach i [1 2 3 4 5 6] [summe: summe + length? pick spielfeld/spieler1 i ]
summe: summe + length? spielfeld/out1
]
if equal? summe 15 [rc: true]
return rc
]
face2top: func [f [object!] /local pt] [
pt: find f/parent-face/pane f
if not tail? next pt [
insert tail f/parent-face/pane f
remove pt
]
]
move-face: func [
"bewegt face-Objekt"
mface [object!] "face 2 move"
dest [pair!] "destination, new offset"
/local rc x y ox oy r phi
] [
rc: none
idle: false
ox: mface/offset/x
oy: mface/offset/y
either animate [
face2top mface
r: maximum 0.05 multiply speed 10
while [not equal? mface/offset dest] [
x: dest/x - mface/offset/x
y: dest/y - mface/offset/y
if all [greater? r 1 lesser? square-root ((y * y) + (x * x)) 10] [r: 1]
either zero? x [
if positive? y [phi: 90]
if negative? y [phi: 270]
] [
either positive? x [
either positive? y [
phi: arctangent abs (y / x)
] [phi: 360 - arctangent abs (y / x) ]
] [
either positive? y [
phi: 180 - arctangent abs (y / x)
] [phi: 180 + arctangent abs (y / x) ]
]
]
ox: ox + (r * cosine phi)
oy: oy + (r * sine phi)
mface/offset/x: to integer! (ox + 0.5)
mface/offset/y: to integer! (oy + 0.5)
all [accel mface/changes: 'offset]
show mface
all [MacOSX wait 1E-5]
]
] [
mface/offset: dest
all [accel mface/changes: 'offset]
show mface
]
idle: true
return rc
]
draw-object: func [
drawplot [block!]
offset [pair!]
/flip
/local foo
] [
append drawplot reduce ['polygon]
foreach element default [
element/1: element/1 * ratio-x
element/2: element/2 * ratio-y
if flip [element/2: negate element/2]
append drawplot reduce [element + offset]
]
]
plot: compose [
pen (water - 30)
fill-pen (water)
]
for i 0 5 1 [
foo: multiply breite i
draw-object plot to pair! reduce [foo 0]
draw-object/flip plot to pair! reduce [foo gridsize/2]
]
show-dice: func [
"Displays the side n of a dice."
obj [object!] "The face object of the dice."
n [integer!] "The side to display."
] [
switch n [
1 [obj/effect: copy [gradient 0x1 245.245.230 205.205.190 draw [pen 20.20.20 fill-pen 10.10.10 circle 21x21 4]]]
2 [obj/effect: copy [gradient 0x1 245.245.230 205.205.190 draw [pen 20.20.20 fill-pen 10.10.10 circle 10x10 4 circle 32x32 4]]]
3 [obj/effect: copy [gradient 0x1 245.245.230 205.205.190 draw [pen 20.20.20 fill-pen 10.10.10 circle 10x32 4 circle 21x21 4 circle 32x10 4]]]
4 [obj/effect: copy [gradient 0x1 245.245.230 205.205.190 draw [pen 20.20.20 fill-pen 10.10.10 circle 10x10 4 circle 32x10 4 circle 10x32 4 circle 32x32 4]]]
5 [obj/effect: copy [gradient 0x1 245.245.230 205.205.190 draw [pen 20.20.20 fill-pen 10.10.10 circle 10x10 4 circle 32x10 4 circle 21x21 4 circle 10x32 4 circle 32x32 4]]]
6 [obj/effect: copy [gradient 0x1 245.245.230 205.205.190 draw [pen 20.20.20 fill-pen 10.10.10 circle 10x10 4 circle 10x21 4 circle 10x32 4 circle 32x10 4 circle 32x21 4 circle 32x32 4]]]
]
]
würfeln: func [
"Dices the dices."
obj [object!] "The face object of the dice."
] [
if not obj/busy [
idle: gewürfelt: false
either game-started [
w1/data: random 6
w2/data: random 6
if animate-dice [w1/rate: w2/rate: 20 w1/busy: w2/busy: true]
show [w1 w2]
while [found? any [w1/busy w2/busy]] [wait 0.1]
clear züge
append züge sort/reverse reduce [w1/data w2/data]
if equal? w1/data w2/data [
insert züge züge
if not hideall [
if any [equal? spieleranzahl 2 equal? spieler 1] [
message/color/timeout ["P A S C H - d o u b l e t :" reform [spielername/text ", you can move the" first züge " fourtimes !!!"] "Make your moves ..."] green 0:00:05
hide-popup
]
]
]
gewürfelt: true
] [
either erster-wurf [
w2/data: random 6
if animate-dice [w2/rate: 20 w2/busy: true]
show [w2]
while [found? any [w2/busy]] [wait 0.1]
game-started: true
either equal? w1/data w2/data [
game-started: erster-wurf: false
if not hideall [
message/color/timeout ["D I C E - a g a i n :" "Equate dices !!!" "Please dice again ..."] orange 0:00:05
hide-popup
]
wechseln/quiet
] [
clear züge
append züge sort/reverse reduce [w1/data w2/data]
either greater? w1/data w2/data [
wechseln/quiet
if not hideall [
message/color/timeout ["G A M E - S T A R T S :" reform [spielername/text "," "you begin the game !!!"] "Make your moves ..."] green 0:00:05
hide-popup
]
] [
either equal? spieleranzahl 1 [
computer2move: true
] [
if not hideall [
message/color/timeout ["G A M E - S T A R T S :" reform [spielername/text "," "you begin the game !!!"] "Make your moves ..."] green 0:00:05
hide-popup
]
]
]
gewürfelt: true
]
] [
w1/data: random 6
if animate-dice [w1/rate: 20 w1/busy: true]
show [w1]
while [found? any [w1/busy]] [wait 0.1]
erster-wurf: true
wechseln/quiet
if equal? spieleranzahl 1 [würfeln w2]
]
]
idle: true
]
]
to-offset: func [
{Ermittelt den neuen Offset des Spielsteins auf dem Spielfeld.}
pos [integer!] "Positon des Spielsteins auf dem Spielfeld."
/computer "Offset für 2.Spieler."
/local rc foo
] [
rc: 800x0
switch pos [
-2 [rc: 365x130]
-1 [rc: 365x340]
0 [rc: 770x230]
1 [rc: 696x444]
2 [rc: 643x444]
3 [rc: 590x444]
4 [rc: 537x444]
5 [rc: 484x444]
6 [rc: 431x444]
7 [rc: 297x444]
8 [rc: 244x444]
9 [rc: 191x444]
10 [rc: 138x444]
11 [rc: 85x444]
12 [rc: 32x444]
13 [rc: 32x26]
14 [rc: 85x26]
15 [rc: 138x26]
16 [rc: 191x26]
17 [rc: 244x26]
18 [rc: 297x26]
19 [rc: 431x26]
20 [rc: 484x26]
21 [rc: 537x26]
22 [rc: 590x26]
23 [rc: 643x26]
24 [rc: 696x26]
]
either positive? pos [
either lesser? pos 13 [
either equal? spieler 2 [
rc: subtract rc multiply 0x40 length? pick spielfeld/spieler2 pos
] [rc: subtract rc multiply 0x40 length? pick spielfeld/spieler1 pos ]
] [
either equal? spieler 2 [
rc: add rc multiply 0x40 length? pick spielfeld/spieler2 pos
] [rc: add rc multiply 0x40 length? pick spielfeld/spieler1 pos ]
]
] [
if equal? pos -1 [
rc: add rc multiply 0x40 either greater-or-equal? foo: length? spielfeld/bar1 2 [2] [foo]
]
if equal? pos -2 [
rc: subtract rc multiply 0x40 either greater-or-equal? foo: length? spielfeld/bar2 2 [2] [foo]
]
]
return rc
]
position?: func [
{Ermittelt die Position des Spielsteins auf dem Spielfeld.}
xy [pair!] "Koordinaten des Spielsteins."
/local rc
] [
rc: 0
switch first xy [
696 [rc: 1]
643 [rc: 2]
590 [rc: 3]
537 [rc: 4]
484 [rc: 5]
431 [rc: 6]
365 [either lesser? second xy 200
[rc: -2]
[rc: -1]]
297 [rc: 7]
244 [rc: 8]
191 [rc: 9]
138 [rc: 10]
85 [rc: 11]
32 [rc: 12]
]
if all [positive? rc lesser? second xy 200] [rc: 25 - rc]
return rc
]
valid?: func [
"Ist Spielzug möglich?"
pos [integer!] {Die aktuelle Postion des Spielsteins auf dem Spielfeld.}
move [integer!] "Die Augenzahl des Spielzuges."
/local rc i foo Eigene Gegner In-Field
] [
rc: false
either any [negative? pos all [equal? spieler 1 not empty? spielfeld/bar1] all [equal? spieler 2 not empty? spielfeld/bar2]] [
if negative? pos [
either equal? pos -1 [
if all [lesser? length? pick spielfeld/spieler2 foo: (25 - move) 2 lesser? length? pick spielfeld/spieler1 foo 5] [rc: true]
] [
if all [lesser? length? pick spielfeld/spieler1 move 2 lesser? length? pick spielfeld/spieler2 move 5] [rc: true]
]
]
] [
either positive? length? pick Spielfeld/spieler1 pos [
Eigene: spielfeld/spieler1
Gegner: spielfeld/spieler2
i: pos - move
] [
Eigene: spielfeld/spieler2
Gegner: spielfeld/spieler1
i: pos + move
]
either lesser? i 1 [
if any [spielfeld/in1 spielfeld/in1: ausspielen?] [
either zero? i [
rc: true
] [
rc: true
for i 6 minimum move (pos + 1) -1 [
if not empty? pick eigene i [rc: false]
]
]
]
] [
either greater? i foo: length? Eigene [
if any [spielfeld/in2 spielfeld/in2: ausspielen?/computer] [
either equal? i add foo 1 [
rc: true
] [
rc: true
for i subtract foo 5 maximum (pos - 1) subtract foo (move - 1) 1 [
if not empty? pick eigene i [rc: false]
]
]
]
] [
if positive? length? pick Eigene pos [
either positive? foo: length? pick Eigene i [
if lesser? foo 5 [rc: true]
] [
if lesser-or-equal? length? pick Gegner i 1 [rc: true]
]
]
]
]
]
return rc
]
make-move: func [
"Bewegt den Spielstein auf die neue Position"
pos [integer!] {Die aktuelle Postion des Spielsteins auf dem Spielfeld.}
move [integer!] "Die Augenzahl des Spielzuges."
/test {Testet den Spielzuge -> Spielstein wird nicht auf dem Spielfeld bewegt!}
/local i coins coin foo
] [
either negative? pos [
either equal? pos -1 [
coin: first spielfeld/bar1
remove spielfeld/bar1
i: 25 - move
if not test [
foo: do coin
move-face :foo to-offset i
foo/effect: [fit key 0.0.0 colorize 255.255.255]
all [accel foo/changes: 'effect]
show foo
]
insert pick Spielfeld/spieler1 i coin
if positive? length? coins: pick Spielfeld/spieler2 i [
coin: first coins
remove coins
if not test [
foo: do coin
move-face :foo to-offset -2
]
insert spielfeld/bar2 coin
spielfeld/in2: false
]
] [
coin: first spielfeld/bar2
remove spielfeld/bar2
i: move
if not test [
foo: do coin
move-face :foo to-offset i
foo/effect: [fit key 0.0.0 colorize 80.80.80]
all [accel foo/changes: 'effect]
show foo
]
insert pick spielfeld/spieler2 i coin
if positive? length? coins: pick spielfeld/spieler1 i [
coin: first coins
remove coins
if not test [
foo: do coin
move-face :foo to-offset -1
]
insert spielfeld/bar1 coin
spielfeld/in1: false
]
]
] [
if positive? length? coins: pick Spielfeld/spieler1 pos [
i: pos - move
coin: first coins
remove coins
either lesser? i 1 [
if not test [
foo: do coin
move-face :foo to-offset 0
]
insert spielfeld/out1 coin
] [
if not test [
foo: do coin
move-face :foo to-offset i
foo/effect: [fit key 0.0.0 colorize 255.255.255]
all [accel foo/changes: 'effect]
show foo
]
insert pick Spielfeld/spieler1 i coin
if positive? length? coins: pick spielfeld/spieler2 i [
coin: first coins
remove coins
if not test [
foo: do coin
move-face :foo to-offset -2
]
insert spielfeld/bar2 coin
spielfeld/in2: false
]
]
]
if positive? length? coins: pick Spielfeld/spieler2 pos [
i: pos + move
coin: first coins
remove coins
either lesser-or-equal? i length? Spielfeld/spieler2 [
if not test [
foo: do coin
move-face :foo to-offset i
foo/effect: [fit key 0.0.0 colorize 80.80.80]
all [accel foo/changes: 'effect]
show foo
]
insert pick Spielfeld/spieler2 i coin
if positive? length? coins: pick Spielfeld/spieler1 i [
coin: first coins
remove coins
if not test [
foo: do coin
move-face :foo to-offset -1
]
insert spielfeld/bar1 coin
spielfeld/in1: false
]
] [
if not test [
foo: do coin
move-face :foo to-offset 0
]
insert spielfeld/out2 coin
]
]
]
if not test [remove züge]
]
get-moves: func [
{Ermittelt alle möglichen Züge des Spielers, welche mit der Augenzahl möglich sind.}
n [integer!] "Augenzahl des Würfels."
/computer "alle Züge des Computers / Spieler 2."
/local pos rc
] [
rc: copy []
pos: 0
either computer [
either empty? spielfeld/bar2 [
foreach element spielfeld/spieler2 [
pos: pos + 1
if all [positive? length? element valid? pos n] [insert rc pos]
]
] [
if valid? -2 n [insert rc -2]
]
] [
either empty? spielfeld/bar1 [
foreach element spielfeld/spieler1 [
pos: pos + 1
if all [positive? length? element valid? pos n] [insert rc pos]
]
] [
if valid? -1 n [insert rc -1]
]
]
return rc
]
best-moves: func [
{Ermittelt die besten Züge des Computers, welche mit der Augenzahl möglich sind.}
mymoves [block!] "Die möglichen Spielzüge."
n [integer!] "Augenzahl des Würfels."
/local rc foo
] [
rc: copy []
foreach element sort mymoves [
either negative? element [
insert rc element
] [
if all [found? foo: add element n lesser? foo 25 equal? length? pick spielfeld/spieler1 foo 1] [insert tail rc element]
]
]
if all [empty? rc spielfeld/in2] [
foreach element mymoves [
if all [found? foo: add element n greater-or-equal? foo 25] [insert tail rc element]
]
]
if all [not rookie empty? rc any [ausspielen? safe?]] [rc: mymoves ]
if empty? rc [
foreach element mymoves [
if all [found? foo: add element n lesser? foo 25 equal? length? pick spielfeld/spieler2 foo 1 greater? length? pick spielfeld/spieler2 element 2] [insert rc element]
]
if empty? rc [
foreach element mymoves [
if all [equal? length? pick spielfeld/spieler2 element 1 found? foo: add element n lesser? foo 25 positive? length? pick spielfeld/spieler2 foo] [insert rc element]
]
]
if all [not rookie empty? rc] [
foreach element mymoves [
if all [equal? length? pick spielfeld/spieler2 element 1 found? foo: add element n lesser? foo 25 empty? pick spielfeld/spieler2 foo] [insert rc element]
]
]
]
if empty? rc [
foreach element mymoves [
if all [found? foo: add element n lesser? foo 25 positive? length? pick spielfeld/spieler2 foo] [
either rookie [
insert rc element
] [
if lesser? element 19 [insert rc element]
]
]
]
]
if empty? rc [
foreach element mymoves [
if all [lesser? element 19 found? foo: add element n lesser? foo 25 greater? foo 18] [insert rc element]
]
]
if all [not rookie empty? rc] [
foreach element mymoves [
if all [lesser? element 19 greater? length? pick spielfeld/spieler2 element 2] [insert rc element]
]
]
if empty? rc [rc: mymoves ]
if not rookie [rc: priorize-moves rc]
return rc
]
optimal-moves: func [
{Ermittelt den optimalen Zug des Computers, welcher mit beiden Augenzahl möglich ist.}
wurf [block!] "Die Augenzahl beider Würfel."
/local rc alle best foo bar1~ bar2~ in1~ in2~ map1~ map2~ out1~ out2~
] [
rc: copy []
map1~: copy/deep spielfeld/spieler1
map2~: copy/deep spielfeld/spieler2
bar1~: copy/deep spielfeld/bar1
bar2~: copy/deep spielfeld/bar2
out1~: copy/deep spielfeld/out1
out2~: copy/deep spielfeld/out2
in1~: spielfeld/in1
in2~: spielfeld/in2
foreach element wurf [
best: best-moves alle: get-moves/computer element element
either empty? best [
break
] [
insert tail rc foo: first best
make-move/test foo element
]
]
spielfeld/spieler1: copy/deep map1~
spielfeld/spieler2: copy/deep map2~
spielfeld/bar1: copy/deep bar1~
spielfeld/bar2: copy/deep bar2~
spielfeld/out1: copy/deep out1~
spielfeld/out2: copy/deep out2~
spielfeld/in1: in1~
spielfeld/in2: in2~
if lesser? length? rc length? wurf [foreach element wurf [ ]
]
return rc
]
computer-moves: func [
] [
foreach element optimal-moves züge [
make-move element first züge
]
computer2move: false
]
check-moves: func [/local rc ] [
if all [found? rc: pick züge 1 empty? moves: either equal? spieler 1 [get-moves rc] [get-moves/computer rc]] [
sort züge
if found? rc: pick züge 1 [moves: either equal? spieler 1 [get-moves rc] [get-moves/computer rc]]
]
return rc
]
sichern: func ["aktuellen Spielstand sichern" ]
[
while [14 < length? spielername/text] [remove at spielername/text length? spielername/text]
show spielername
poke spielstand spieler reduce [
'name copy spielername/text
'time to integer! to time! time/text
]
]
wechseln: func [
"Führt den Spielerwechsel durch."
/quiet
/local element
] [
sichern
spieler: spieler + 1
if greater? spieler 2 [spieler: 1]
element: pick spielstand spieler
spielername/text: select element 'name
time/text: to time! select element 'time
kb/effect: pick [[fit key 0.0.0 colorize 255.255.255] [fit key 0.0.0 colorize 80.80.80]] spieler
if any [equal? spieleranzahl 2 equal? spieler 1] [focus spielername]
show [spielername kb time]
if not quiet [
clear züge
clear moves
if all [equal? spieleranzahl 2 not hidereq not hideall] [
message/color/timeout ["P L A Y E R S - C H A N G E :" reform [spielername/text "," "it´s your turn !!!"] "Dice & make your moves ..."] yellow 0:00:05
hide-popup
]
]
]
gewonnen?: func ["Hat ein Spieler das Spiel bereits gewonnen?" ] [
return any [equal? length? spielfeld/out1 15 equal? length? spielfeld/out2 15]
]
layout [foo: box 40x40 effect [gradient 1x1 200.200.200 25.25.25 oval key 0.0.0 colorize 255.255.255]]
coin-img: to image! foo
board: layout [
style silver-btn button edge [color: bg-color] effects reduce [compose [gradient 0x1 (bg-color + 10) (bg-color - 20)] compose [gradient 0x-1 (bg-color + 10) (bg-color - 20)]]
style btn-dice box 50x50 (ivory - 10) edge [size: 4x4 effect: 'bevel color: (ivory - 100)] effect [gradient 0x1 245.245.230 205.205.190 draw [pen 20.20.20 fill-pen 10.10.10 circle 21x21 4]] feel [
engage: func [face action event] [
switch action [
time [if not face/state [face/blinker: not face/blinker]
if face/busy [
if zero? face/data: face/data - 1 [face/data: 6]
if equal? 8 face/rate: face/rate - 1 [face/rate: none face/busy: false]
show-dice face face/data
]]
down [face/state: on]
alt-down [face/state: on]
up [if face/state [do-face face none] face/state: off]
alt-up [if face/state [do-face-alt face none] face/state: off]
over [face/state: on]
away [face/state: off]
]
cue face action
show face
]
] with [rate: none busy: false] [
unfocus
if all [idle not gewürfelt] [
würfeln face
show face
if game-started [
if any [none? check-moves empty? moves] [
computer2move: false
wechseln
gewürfelt: false
if all [equal? spieleranzahl 1 equal? spieler 2] [
wait 0.8
würfeln w2
computer2move: true
]
]
if all [equal? spieler 2 computer2move] [
computer-moves
wechseln
gewürfelt: false
]
]
]
] [
unfocus
if all [idle not gewürfelt] [
würfeln face
show face
if game-started [
if any [none? check-moves empty? moves] [
computer2move: false
wechseln
gewürfelt: false
if all [equal? spieleranzahl 1 equal? spieler 2] [
wait 0.8
würfeln w2
computer2move: true
]
]
if all [equal? spieler 2 computer2move] [
computer-moves
wechseln
gewürfelt: false
]
]
]
]
style btn-coin-light box coin-img effect [fit key 0.0.0 colorize 255.255.255] feel [
over: func [face action event /local p a foo] [
if all [hint idle equal? spieler 1 found? a: pick züge 1 valid? p: position? face/offset a] [
either positive? p [foo: do first pick spielfeld/spieler1 p] [foo: do first spielfeld/bar1]
either action [
foo/effect: [fit key 0.0.0 colorize 180.180.180]
] [
foo/effect: [fit key 0.0.0 colorize 255.255.255]
]
all [accel foo/changes: 'effect]
show foo
]
]
engage: func [face action event /local a p] [
if all [idle equal? spieler 1] [
switch action [
down [if all [equal? spieler 1 found? a: pick züge 1 not empty? moves valid? p: position? face/offset a] [
make-move p a
either gewonnen? [
game-started: false
either not empty? spielfeld/out2 [
message/color ["C O N G R A T U L A T I O N:" reform [spielername/text "won the game with" points? "points!!!"] "Start all over again ..."] green
] [
either any [not empty? spielfeld/bar2 not empty? pick spielfeld/spieler2 1 not empty? pick spielfeld/spieler2 2 not empty? pick spielfeld/spieler2 3 not empty? pick spielfeld/spieler2 4 not empty? pick spielfeld/spieler2 5 not empty? pick spielfeld/spieler2 6] [
message/color ["B A C K G A M M O N:" reform [spielername/text "won the game with" points? "points!!!"] "Start all over again ..."] green
] [
message/color ["G A M M O N:" reform [spielername/text "won the game with" points? "points!!!"] "Start all over again ..."] green
]
]
update-highscore copy spielername/text points? time/text
if ulf [save-file]
unview/only board
] [
if any [none? a: pick züge 1 empty? moves: get-moves a] [
wechseln
gewürfelt: false
if equal? spieleranzahl 1 [
würfeln w1
either any [none? check-moves empty? moves] [
wechseln
gewürfelt: false
] [
computer-moves
if gewonnen? [
game-started: false
message/color ["G A M E - O V E R:" reduce ["Sorry" select first spielstand 'name ", you´ve lost the game !"] "Try it again ..."] orange
unview/only board
]
wechseln
gewürfelt: false
]
]
]
]
]
]
alt-down [if equal? spieler 1 [
if equal? copy züge sort züge [sort/reverse züge]
]
]
]
]
]
]
style btn-coin-dark box coin-img effect [fit key 0.0.0 colorize 80.80.80] feel [
over: func [face action event /local p a foo] [
if all [hint idle equal? spieleranzahl 2 equal? spieler 2 found? a: pick züge 1 valid? p: position? face/offset a] [
either positive? p [foo: do first pick spielfeld/spieler2 p] [foo: do first spielfeld/bar2]
either action [
foo/effect: [fit key 0.0.0 colorize 140.140.140]
] [
foo/effect: [fit key 0.0.0 colorize 80.80.80]
]
all [accel foo/changes: 'effect]
show foo
]
]
engage: func [face action event /local a p] [
if all [idle equal? spieleranzahl 2 spieler 2] [
switch action [
down [if all [equal? spieleranzahl 2 equal? spieler 2 found? a: pick züge 1 not empty? moves valid? p: position? face/offset a] [
make-move p a
either gewonnen? [
game-started: false
either not empty? spielfeld/out1 [
message/color ["C O N G R A T U L A T I O N:" reform [spielername/text "won the game with" points?/computer "points!!!"] "Start all over again ..."] green
] [
either any [not empty? spielfeld/bar1 not empty? pick spielfeld/spieler1 24 not empty? pick spielfeld/spieler1 23 not empty? pick spielfeld/spieler1 22 not empty? pick spielfeld/spieler1 21 not empty? pick spielfeld/spieler1 20 not empty? pick spielfeld/spieler1 19] [
message/color ["B A C K G A M M O N:" reform [spielername/text "won the game with" points?/computer "points!!!"] "Start all over again ..."] green
] [
message/color ["G A M M O N:" reform [spielername/text "won the game with" points?/computer "points!!!"] "Start all over again ..."] green
]
]
update-highscore copy spielername/text points?/computer time/text
if ulf [save-file]
unview/only board
] [
if any [none? a: pick züge 1 empty? moves: get-moves/computer a] [wechseln gewürfelt: false]
]
]
]
alt-down [if all [equal? spieleranzahl 2 equal? spieler 2] [
if equal? copy züge sort züge [sort/reverse züge]
]
]
]
]
]
]
backdrop bg-color
across
box (gridsize + 11) bg-color edge [size: 5x5 color: bg-color effect: 'ibevel] effect reduce ['draw plot]
pad 60
box (gridsize + 11) bg-color edge [size: 5x5 color: bg-color effect: 'ibevel] effect reduce ['draw plot] return
pad 110x5
panel 110x24 black edge [color: bg-color size: 2x2 effect: 'ibevel] [
across origin 0x0 space 0x0
pad 1x1
spielername: field 88x17 black middle center bold select first spielstand 'name font [color: orange size: 14] with [edge: none]
pad 2x3
kb: box 12x12 coin-img effect [fit key 0.0.0 colorize 255.255.255] with [feel: none]
]
pad 104 silver-btn 66x24 "Close" "Closed" keycode [#"^["] [
either game-started [
if confirm {Game is not finished! Do you really want to close the window?} [game-started: false unview/only board]
] [unview/only board ]
]
pad 60
panel 50x24 [
across origin 0x3 space 0x0
text 50 right middle underline black "Time: " with [feel: none]
]
pad 5
time: text 70x24 right middle bold edge [color: bg-color size: 2x2 effect: 'ibevel] orange black font [color: orange size: 16] "0:00:00" with [
feel: make feel [
engage: func [face action event /local i] [
if not game-started [exit]
if last-time <> now/time [
last-time: now/time
i: 1 + (to integer! to time! face/text)
face/text: to time! i
show face
]
if all [not ulf zero? face/text // to time! 30] [
message/color reduce [reform [system/script/Header/Name "D E M O - V E R S I O N !"] reform ["If you like to play without interruption:"] reform ["Contact" system/script/Header/Rights " & request a license-key."]] orange
]
]
]
rate: 1
] return
below
at (to pair! reduce [first gridsize divide second gridsize 2]) + 40x-30
w1: btn-dice
w2: btn-dice
at (to pair! reduce [first gridsize divide second gridsize 2]) + 40x-30 - 0x160
box 50x140 edge [color: bg-color - 30 size: 1x1 effect: 'ibevel]
at (to pair! reduce [first gridsize divide second gridsize 2]) + 40x-30 + 0x130
box 50x140 edge [color: bg-color - 30 size: 1x1 effect: 'ibevel]
space 0x0
at 696x26 c1: btn-coin-light c2: btn-coin-light
at 32x26 c3: btn-coin-light c4: btn-coin-light c5: btn-coin-light c6: btn-coin-light c7: btn-coin-light
at 244x364 c8: btn-coin-light c9: btn-coin-light c10: btn-coin-light
at 431x284 c11: btn-coin-light c12: btn-coin-light c13: btn-coin-light c14: btn-coin-light c15: btn-coin-light
at 696x404 p1: btn-coin-dark p2: btn-coin-dark
at 32x284 p3: btn-coin-dark p4: btn-coin-dark p5: btn-coin-dark p6: btn-coin-dark p7: btn-coin-dark
at 244x26 p8: btn-coin-dark p9: btn-coin-dark p10: btn-coin-dark
at 431x26 p11: btn-coin-dark p12: btn-coin-dark p13: btn-coin-dark p14: btn-coin-dark p15: btn-coin-dark
]
random/seed to-integer now/time
view/kf center-face main
shutdown
In the wagering community, everybody put wagers on several wagering games, and there are many individuals who also like to place bets on the sports activities. Today, sports betting is significantly superior in requirement. By addressing this web site, individuals will receive information about major totosite.
ReplyDelete