Tuesday, 25 September 2012

Backgammon game

TGD Consulting is a software house that use a lo Rebol, they made the following backgammon game in pure Rebol, the game is free, but you can download the license to avoid the interruption messages about buying a license. You can play against pc or against a human player.
The game is cool and computer play well, if you like backgammon, you should see it:
http://www.tgd-consulting.de/Download.html#BackIt

Original source:
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

No comments:

Post a Comment