Thursday, 27 September 2012

Brain it!

TGD Consulting is a software house that use a lo Rebol, they made the following game in pure Rebol.
The game will show you some numbers for few seconds, then they disappear and are covered of empty boxes; you have to click the boxes from the lower number to the higher number. It's a memory game, very difficult:
Here the source:
REBOL [
    Title: "Brain-It!"
    Home: http://www.TGD-Consulting.DE/Download.html
    Name: "Brain-It!"
    File: %BrainIt.r
    Needs: 'View
    Date: 29-Jul-2006
    Version: 1.0.0
    Author: "Dirk Weyand"
    Owner: "Dirk Weyand"
    Rights: "TGD-Consulting"
    Purpose: "A game to train your brain."
    Comment: {
Brain-It! is a game using REBOL/View.
It is a braintwister-game inspired by
the theories of Dr. Ryuta Kawashima.
To play this game memories the numbers
appearing on the grid and click on their
position from lowest to highest value.
The numbers will vanish, so you
must remember where they are.
Play Brain-It! everyday to
enhance your mental-fitness.
This game is dedicated to
my wonderful beloved wife.
Have fun & enjoy this game !}
    History: [
        {0.0.1   ^-21-Jul-2006 ^-"initial release"^/}
        {0.1.0   ^-22-Jul-2006 ^-"added timer"^/}
        {0.2.0   ^-23-Jul-2006 ^-"added highscore"^/}
        {0.2.1   ^-23-Jul-2006 ^-"changed background color"^/}
        {0.2.2   ^-23-Jul-2006 ^-"fixed game-play"^/}
        {0.3.0   ^-23-Jul-2006 ^-"added count-down"^/}
        {0.4.0   ^-27-Jul-2006 ^-"added levels 12-16"^/}
        {1.0.0   ^-29-Jul-2006 ^-"first public release"^/}
    ]
    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^/Brain-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 - 20
blau: 122.154.198
lic-read: ulf: false
main-offset: none
debug: false
Stufe: [4 5 6 7 8 9 10 12 14 16]
random/seed now
game-over: true
started: count: false
Index: 1
score: 0
time: 0
begin: now
Brainiacs: 0
MaxMist: 3
bg-effect: compose [gradient 0x1 (bg-color) (bg-color - 30.30.10)]
copydate: copy find/tail first 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] [
    [[score "   1" name "T G D         " time "1:00:01" date "23-Jul-2006"]]
]
btn-styles: stylize [
    btn: button no-wrap edge [color: gray size: 1x1] effects compose/deep [[gradient 0x1 (bg-color - 10 + 32) (bg-color - 10 - 32)] [gradient 0x-1 (bg-color - 10 + 32) (bg-color - 10 - 32)]] font [color: ivory - 20 colors/1: color]
    small-btn: box 19x19 no-wrap edge [size: 1x1 effect: 'bevel color: gray] font [color: ivory -20 colors/1: color] feel [
        redraw: func [face act pos] [
            face/edge/effect: pick [ibevel bevel] face/state
        ]
        over: func [face action event] [
            if all [face/font face/font/colors] [
                face/font/color: pick face/font/colors not action
                show face
                face/font/color: first face/font/colors
            ]
        ]
        engage: func [face action event] [
            switch action [
                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]
            ]
            show [face]
        ]
    ]
]
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: bg-color / 3
        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 [
            backdrop effect bg-effect
            across
            pad x-p
            button x-hdl copy hdl middle center font [size: 20 colors: compose [(c1) (c1 - 40)]] edge [color: gray size: 1x1 effect: 'bevel] [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
    ]
    lay/pane/2/effects: lay/pane/2/color: none
    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 ['gradient 0x1 (bg-color) (bg-color - 30.30.10) '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 bg-color / 3 bg-color + 40 edge [color: gray size: 2x2 effect: 'ibevel] with [feel: none]
    f-sld: slider f-txt/size/y * 0x1 + 16x0 bg-color / 1.5 bg-color - 15 edge [color: gray] [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
    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
    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
either any [system/version > 1.3.0 equal? system/product 'Link] [f-sld/pane/1/edge/color: gray ] [f-sld/pane/edge/color: gray ]
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? config-file] [
    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 [myoffset] read/direct/lines config-file] [
        if found? myoffset [error? try [main-offset: to pair! myoffset]]
    ]
]
seconds: func [
    "Compute difference between dates in seconds."
    a [date!] "first date"
    b [date!] "second date"
] [((b - a) * to decimal! 86400) + ((to decimal! b/time) - (to decimal! a/time)) + ((a/zone/hour - b/zone/hour) * to decimal! 3600) ]
shutdown: func ["Exits the programm." ] [
    if ulf [
        write config-file reduce [lay-main/offset 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 score time] [
    clear scorelist/text
    i: 1
    rank: " "
    append scorelist/text {TOP-20
      Score       Name         Time         Date        
-------------------------------------------------------}

    foreach element highscores [
        append scorelist/text newline
        clear rank
        if i < 10 [append rank 0]
        append rank i
        append rank ". "
        score: select element 'score
        while [3 > length? score] [insert score " "]
        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 score " " select element 'name " " 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"
    myscore [integer!] "The score in the game"
    myname [string!] "The name of the player"
    mytime [time!] "The number of cards on the playfield"
    /local index
] [
    while [14 < length? myname] [remove at myname length? myname]
    while [14 > length? myname] [append myname " "]
    index: 1
    foreach element highscores [
        either myscore > to integer! trim select element 'score [
            insert at highscores index to block! mold reduce ['score form myscore 'name myname 'time form mytime 'date form now/date]
            break
        ] [
            if all [(equal? myscore to integer! trim select element 'score) (mytime < to time! trim select element 'time)] [
                insert at highscores index to block! mold reduce ['score form myscore 'name myname 'time form mytime 'date form now/date]
                break
            ]
        ]
        index: index + 1
    ]
    while [20 < length? highscores] [remove at highscores length? highscores]
    init-highscore
]
highscore: layout [
    style 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]]
    backdrop effect [gradient 0x1 164.200.255 80.108.142]
    across
    pad 45 h1 underline "Highscores" 28.52.86 with [feel: none]
    pad 80 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 370x3 edge [size: 1x1 color: sky effect: 'bevel] return
    scorelist: code 28.52.86 center bold no-wrap 370x100 " " 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 370x3 edge [size: 1x1 color: sky effect: 'bevel] return
]
init-highscore
history: layout [
    styles btn-styles
    backdrop effect reduce ['gradient 0x-1 (bg-color - 20) (bg-color - 10)]
    origin 0x0
    across
    pad 20x10 banner "History" 306 ivory - 20 with [feel: none] return
    pad 20 h-txt: text 294x80 bg-color / 3 bg-color + 40 no-wrap edge [color: (bg-color - 25) size: 2x2 effect: 'ibevel] with [feel: none]
    pad -8x0 h-sld: slider h-txt/size/y * 0x1 + 16x0 bg-color / 1.5 bg-color - 15 edge [color: (bg-color - 25)] [scroll-slider-text h-txt h-sld] return
    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]
    at 330x130 box 20x20
    at 330x1 small-btn "X" keycode [#"^["] [unview/only history] [unview/only history]
]
h-txt/text: system/script/header/History
either any [system/version > 1.3.0 equal? system/product 'Link] [h-sld/pane/1/edge/color: (bg-color - 25)] [h-sld/pane/edge/color: (bg-color - 25)]
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]
    ]
]
sendmail: layout [
    styles btn-styles
    backdrop effect reduce ['gradient 0x-1 (bg-color - 20) (bg-color - 10)]
    vh2 ivory - 20 reform ["Send email to" system/script/header/Name "author:"] with [feel: none]
    msg: area "Type your message here ..." 250x60 wrap bg-color + 40 edge [color: (bg-color - 25)] font [color: bg-color / 3]
    across return
    btn 80 "Send" "Send ..." [
        unfocus
        sending: flash "Sending ..."
        either error? try [
            hdr: make system/standard/email [subject: reform [system/script/header/Name system/script/header/Version]]
            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
        ]
    ] [
        unfocus
        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 82 btn 80 "Cancel" "Canceled" keycode [#"^["] [unfocus unview/only sendmail] [unfocus 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 bg-effect
    panel 335x275 bg-color - 25 edge [size: 2x2 color: gray effect: 'bevel] effect reduce ['gradient 0x1 (bg-color - 20) (bg-color - 10)] [
        origin 15x15
        space 0
        banner "About ..." 300 ivory - 20 with [feel: none]
        pad 0x5
        panel 300x205 edge [size: 1x1 effect: 'ibevel color: bg-color - 25] [
            style link text bold font [colors: reduce [0.0.0 (bg-color / 4)]]
            backdrop (bg-color + 40) effect reduce ['gradient 0x1 (bg-color + 25) (bg-color + 40)]
            origin 23
            across
            at 23x10
            pa-hd1: h2 underline form system/script/header/Name (bg-color / 2.7) with [feel: none]
            pa-hd2: h2 reform ["Version:" system/script/header/Version] (bg-color / 2.7) font [colors: reduce [(bg-color / 2.7) (bg-color / 4)]] [unfocus view/kf/new/options center-face history [no-title]] return
            space 0
            box 250x3 edge [size: 1x1 color: bg-color effect: 'bevel] return
            credits: text (bg-color / 2.7) center bold no-wrap 250x80 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: bg-color effect: 'bevel] return
            space 0
            pad 15 text (bg-color / 2.7) bold "written by" with [feel: none]
            link (bg-color / 2.5) system/script/header/Author [unfocus sendmail/offset: about/offset + 200x220 view/kf/new/options sendmail [no-title]] return
            pad 15 text (bg-color / 2.7) bold reform ["Copyright" copydate ","] with [feel: none]
            space 8 link (bg-color / 2.7) system/script/header/Rights [
                unfocus
                if request ["Connect to the homepage of TGD-Consulting ?" "Browse" "Cancel"] [
                    error? try [browse system/script/header/Home]
                ]
            ] return
            pad 15 text (bg-color / 2.7) bold no-wrap reform ["Updated: " modified? system/options/script] with [feel: none] return
        ]
        at 290x1
        small-btn "?" keycode [#"?"] [view/kf/new/options center-face history [no-title]] [view/kf/new/options center-face history [no-title]]
        at 311x1
        small-btn "X" keycode [#"^["] [unview/only about] [unview/only about]
    ]
]
xsize: to integer! ((300 - (first pa-hd2/offset + first pa-hd2/size - first pa-hd1/offset)) / 2)
pa-hd2/offset: to pair! join xsize + first pa-hd2/offset - first pa-hd1/offset ["x" second pa-hd2/offset]
pa-hd1/offset: to pair! join xsize ["x" second pa-hd1/offset]
show [pa-hd1 pa-hd2]
credits/text: {
- - - - - -
}

insert credits/text form system/script/header/Comment
insert credits/text reform [">>> " system/script/Header/Name " <<<" newline]
insert credits/text {
\|/
@ @
----------oOO-(_)-OOo----------
-= T G D =-
is proud to
present
}

either ulf [
    insert tail credits/text reform ["This software is registered to" newline licensee "."]
    if date? expiry [
        insert tail credits/text reform [newline "Your license will expire at" newline expiry "!"]
    ]
] [
    either all [value? 'expiry date? expiry] [insert tail credits/text reform ["This software has been registered to" newline licensee "," newline "but your license expired !" newline ]
    ] [
        insert tail credits/text {This software is not registered yet
and runs in D E M O - mode only !
}

    ]
    insert tail credits/text reform ["^/To register and run the full version of"
        newline system/script/Header/Name {, contact TGD-Consulting
at the following email address :
info@TGD-Consulting.de}
]
]
insert tail credits/text "^/^/- - - - - -"
lay-main: layout [
    styles btn-styles
    style ld led edge [size: 1x1 color: gray + 30] feel [
        redraw: func [f a p] [
            either f/data [
                f/color: f/colors/1
                clear f/effect
                f/edge/effect: 'bevel
            ] [
                f/color: f/colors/2
                insert f/effect 'cross
                f/edge/effect: 'ibevel
            ]
        ]
        detect: none
        over: none
        engage: func [f a e] [
            if all [game-over found? select [up alt-up] a] [beginne-Spiel]
        ]
    ]
    backdrop effect bg-effect
    across
    vh1 224 system/script/header/title ivory - 20 rate 0:01:30 feel [
        engage: func [face action event] [
            if all [not ulf not game-over equal? action 'time] [
                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
            ]
        ]
    ] return
    panel 224x224 edge [size: 2x2 color: gray effect: 'ibevel] feel [
        engage: func [f a e] [
            if all [game-over found? select [up alt-up] a] [beginne-Spiel]
        ]
    ] [
        backcolor bg-color + 40
        style bx box 40x40 center middle no-wrap edge [size: 1x1 color: gray - 80] font [size: 32 shadow: none color: gray - 80 colors/1: color] feel [
            over: func [f a e] [
                either a [if empty? f/text [f/edge/color: orange show f f/edge/color: gray - 80]] [show f]
            ]
            engage: func [f a e] [
                if all [started empty? f/text found? select [up alt-up] a] [
                    insert f/text f/data
                    f/edge/size: 0x0
                    either equal? f/data pick Spiel index [
                        index: index + 1
                        show f
                        score: score + 1
                        clear sc-txt/text
                        insert sc-txt/text score
                        show sc-txt
                        if greater? index length? Spiel [
                            stoppe-Zeit
                            wait 1
                            Stufe: next Stufe
                            beginne-Spiel
                        ]
                    ] [
                        stoppe-Zeit
                        f/edge/color: red
                        f/effect: [cross]
                        show f
                        Brainiacs: Brainiacs + 1
                        switch Brainiacs [
                            1 [b1/data: false show b1]
                            2 [b2/data: false show b2]
                            3 [b3/data: false show b3]
                        ]
                        started: false
                        zeige-Spiel
                        wait 2.5
                        either greater-or-equal? Brainiacs MaxMist [
                            game-over: true
                            message/color ["G A M E - O V E R:" "Train your brain !!!" "Start all over again ..."] orange
                            update-highscore score copy spielername/text to time! time
                            if ulf [save-file]
                        ] [
                            Stufe: back Stufe
                            beginne-Spiel
                        ]
                    ]
                ]
            ]
        ]
        space 0x0
        c1: bx "" edge [size: 0x0]
        c2: bx "" edge [size: 0x0]
        c3: bx "" edge [size: 0x0]
        c4: bx "" edge [size: 0x0]
        c5: bx "" edge [size: 0x0]
        c6: bx "" edge [size: 0x0]
        c7: bx "" edge [size: 0x0]
        c8: bx "" edge [size: 0x0]
        c9: bx "" edge [size: 0x0]
        c10: bx "" edge [size: 0x0]
        c11: bx "" edge [size: 0x0]
        c12: bx "" edge [size: 0x0]
        c13: bx "" edge [size: 0x0]
        c14: bx "" edge [size: 0x0]
        c15: bx "" edge [size: 0x0]
        c16: bx "" edge [size: 0x0]
        at 90x224 t1: text 40x40 "" gray - 80 center middle no-wrap font [size: 32] rate 3 edge [size: 1x1 color: gray + 30 effect: 'bevel] effect bg-effect feel [
            engage: func [f a e /local foo] [
                if all [count equal? a 'time] [
                    if empty? f/text [
                        insert f/text 3
                        show f
                        while [greater? f/offset/y 188] [f/offset/y: f/offset/y - 1 show f wait 0.01]
                    ]
                    if greater-or-equal? subtract now/time/precise f/data 0:00:01 [
                        f/data: now/time/precise
                        foo: subtract to integer! f/text 1
                        clear f/text
                        insert f/text foo
                        show f
                        if zero? foo [
                            count: false
                            while [lesser? f/offset/y 224] [f/offset/y: f/offset/y + 1 show f wait 0.01]
                            clear f/text
                            set-Spiel
                            wait 1
                            blank-Spiel
                            begin: now
                        ]
                    ]
                ]
            ]
        ]
    ] return
    spielername: field "Your Name" edge [size: 2x2 color: gray] bg-color / 5 center middle bold 80 font [color: orange size: 14]
    pad -2x6 b1: ld true b2: ld true b3: ld true
    pad -2x-6 panel 80x24 bg-color / 5 edge [size: 2x2 effect: 'ibevel color: gray] [
        origin 0x0
        space 0x0
        across
        pad 1x0 text 42x20 "Score:" center bold middle no-wrap orange bg-color / 5 font [size: 14] [view/new/options center-face highscore [no-title]] [view/new/options center-face highscore [no-title]]
        pad -1x0 sc-txt: text 38x20 form score center bold middle no-wrap orange bg-color / 5 font [size: 16] with [feel: none]
    ] return
    pad 0x-6 lnk-home: text 224 center ivory - 20 no-wrap join "(c) " [copydate " " system/script/header/Rights] with [feel: none] [
        if request ["Connect to the homepage of TGD-Consulting ?" "Browse" "Cancel"] [
            error? try [browse system/script/header/Home]
        ]
    ] [
        if request ["Connect to the homepage of TGD-Consulting ?" "Browse" "Cancel"] [
            error? try [browse system/script/header/Home]
        ]
    ] return
    at 242x2
    lnk-exit: small-btn "X" keycode [#"^["] [
        if confirm reform ["Do you really want to quit" system/script/title "?"] [shutdown]
    ] [
        if confirm reform ["Do you really want to quit" system/script/title "?"] [shutdown]
    ]
    pad -48x0
    small-btn "?" keycode [#"?"] [view/new/title center-face about join "about " system/script/header/Name] [view/new/title center-face about join "about " system/script/header/Name]
]
lay-main/feel: make lay-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 lay-main]]
        ]
        if rc [event]
    ]
]
stoppe-Zeit: func [
] [time: time + seconds begin now ]
beginne-Spiel: func [
] [
    if game-over [
        Stufe: head Stufe
        game-over: false
        time: score: Brainiacs: 0
        clear sc-txt/text
        insert sc-txt/text score
        show sc-txt
        b1/data: b2/data: b3/data: true
        show [b1 b2 b3]
    ]
    started: false
    init-Spiel
    count: true
    t1/data: now/time/precise
]
clear-nums: func [/local obj i ] [
    i: 0
    loop 16 [
        i: i + 1
        obj: do to word! join 'c i
        clear obj/text
    ]
]
size-edges: func [
    val [pair!]
    /only obj [object!]
] [
    either only [
        obj/edge/size: val
    ] [c1/edge/size: c2/edge/size: c3/edge/size: c4/edge/size: c5/edge/size: c6/edge/size: c7/edge/size: c8/edge/size: c9/edge/size: c10/edge/size: c11/edge/size: c12/edge/size: c13/edge/size: c14/edge/size: c15/edge/size: c16/edge/size: val ]
]
color-edges: func [
    col [tuple!]
    /only obj [object!]
] [
    either only [
        obj/edge/color: col
    ] [c1/edge/color: c2/edge/color: c3/edge/color: c4/edge/color: c5/edge/color: c6/edge/color: c7/edge/color: c8/edge/color: c9/edge/color: c10/edge/color: c11/edge/color: c12/edge/color: c13/edge/color: c14/edge/color: c15/edge/color: c16/edge/color: col ]
]
zeige-Spiel: func [/local obj i lst ] [
    size-edges 0x0
    lst: copy []
    clear lst
    i: 0
    loop 16 [
        i: i + 1
        insert lst to word! join 'c i
        obj: do first lst
        if empty? obj/text [insert obj/text obj/data]
    ]
    show lst
]
init-Spiel: func [
] [
    if tail? Stufe [Stufe: back Stufe]
    switch/default first Stufe [
        12 [Spiel: copy random [1 2 3 4 5 6 7 8 9 10 11 12]]
        14 [Spiel: copy random [1 2 3 4 5 6 7 8 9 10 11 12 13 14]]
        16 [Spiel: copy random [1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16]]
    ] [
        Spiel: copy/part random [1 2 3 4 5 6 7 8 9 10] first Stufe
    ]
    c1/effect: c2/effect: c3/effect: c4/effect: c5/effect: c6/effect: c7/effect: c8/effect: c9/effect: c10/effect: c11/effect: c12/effect: c13/effect: c14/effect: c15/effect: c16/effect: [fit]
    clear-nums
    size-edges 1x1
    color-edges 48.48.48
    switch length? Spiel [
        4 [c1/offset: 65x65
            c2/offset: 115x65
            c3/offset: 65x115
            c4/offset: 115x115
            c5/offset: c6/offset: c7/offset: c8/offset: c9/offset: c10/offset: c11/offset: c12/offset: c13/offset: c14/offset: c15/offset: c16/offset: 300x300
        ]
        5 [c1/offset: 35x35
            c2/offset: 145x35
            c3/offset: 90x90
            c4/offset: 35x145
            c5/offset: 145x145
            c6/offset: c7/offset: c8/offset: c9/offset: c10/offset: c11/offset: c12/offset: c13/offset: c14/offset: c15/offset: c16/offset: 300x300
        ]
        6 [c1/offset: 145x35
            c2/offset: 90x90
            c3/offset: 145x90
            c4/offset: 35x145
            c5/offset: 90x145
            c6/offset: 145x145
            c7/offset: c8/offset: c9/offset: c10/offset: c11/offset: c12/offset: c13/offset: c14/offset: c15/offset: c16/offset: 300x300
        ]
        7 [c1/offset: 90x35
            c2/offset: 145x35
            c3/offset: 35x90
            c4/offset: 90x90
            c5/offset: 145x90
            c6/offset: 35x145
            c7/offset: 90x145
            c8/offset: c9/offset: c10/offset: c11/offset: c12/offset: c13/offset: c14/offset: c15/offset: c16/offset: 300x300
        ]
        8 [c1/offset: 15x65
            c2/offset: 65x65
            c3/offset: 115x65
            c4/offset: 165x65
            c5/offset: 15x115
            c6/offset: 65x115
            c7/offset: 115x115
            c8/offset: 165x115
            c9/offset: c10/offset: c11/offset: c12/offset: c13/offset: c14/offset: c15/offset: c16/offset: 300x300
        ]
        9 [c1/offset: 35x35
            c2/offset: 90x35
            c3/offset: 145x35
            c4/offset: 35x90
            c5/offset: 90x90
            c6/offset: 145x90
            c7/offset: 35x145
            c8/offset: 90x145
            c9/offset: 145x145
            c10/offset: c11/offset: c12/offset: c13/offset: c14/offset: c15/offset: c16/offset: 300x300
        ]
        10 [c1/offset: 65x35
            c2/offset: 115x35
            c3/offset: 15x90
            c4/offset: 65x90
            c5/offset: 115x90
            c6/offset: 165x90
            c7/offset: 15x145
            c8/offset: 65x145
            c9/offset: 115x145
            c10/offset: 165x145
            c11/offset: c12/offset: c13/offset: c14/offset: c15/offset: c16/offset: 300x300
        ]
        12 [c1/offset: 15x35
            c2/offset: 65x35
            c3/offset: 115x35
            c4/offset: 165x35
            c5/offset: 15x90
            c6/offset: 65x90
            c7/offset: 115x90
            c8/offset: 165x90
            c9/offset: 15x145
            c10/offset: 65x145
            c11/offset: 115x145
            c12/offset: 165x145
            c13/offset: c14/offset: c15/offset: c16/offset: 300x300
        ]
        14 [c1/offset: 15x15
            c2/offset: 65x15
            c3/offset: 165x15
            c4/offset: 15x65
            c5/offset: 65x65
            c6/offset: 115x65
            c7/offset: 165x65
            c8/offset: 15x115
            c9/offset: 65x115
            c10/offset: 115x115
            c11/offset: 165x115
            c12/offset: 15x165
            c13/offset: 115x165
            c14/offset: 165x165
            c15/offset: c16/offset: 300x300
        ]
        16 [c1/offset: 15x15
            c2/offset: 65x15
            c3/offset: 115x15
            c4/offset: 165x15
            c5/offset: 15x65
            c6/offset: 65x65
            c7/offset: 115x65
            c8/offset: 165x65
            c9/offset: 15x115
            c10/offset: 65x115
            c11/offset: 115x115
            c12/offset: 165x115
            c13/offset: 15x165
            c14/offset: 65x165
            c15/offset: 115x165
            c16/offset: 165x165
        ]
    ]
    show [c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 c11 c12 c13 c14 c15 c16]
]
set-Spiel: func [/local obj i lst ] [
    size-edges 0x0
    lst: copy []
    clear lst
    for i 1 length? Spiel 1 [
        insert lst to word! join 'c i
        obj: do first lst
        insert obj/text obj/data: pick Spiel i
    ]
    show lst
    sort Spiel
    index: 1
]
blank-Spiel: func [
] [
    clear-nums
    size-edges 1x1
    show [c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 c11 c12 c13 c14 c15 c16]
    started: true
]
lay-main/size/y: lnk-home/offset/y + lnk-home/size/y + 2
lay-main/size/x: lnk-exit/offset/x + lnk-exit/size/x + 2
either main-offset [lay-main/offset: main-offset] [center-face lay-main]
view/kf lay-main
shutdown

No comments:

Post a Comment