Friday 31 August 2012

Tetris

Here another game made in Rebol, it's a Tetris clone: RebTris

Here the source:

REBOL [
    title: "REBtris"
    author: "Frank Sievertsen"
    version: 1.0.2
    date: 2-Apr-2001 ;30-Jul-2000
    copyright: "Freeware"
]
rebtris: context [
    field-size: 10x20
    stone-size: 20x20
    stones: {
        xxxx
        xxx
        x
        xxx
        x
        xxx
          x
        xx
        xx
        xx
        xx
        xx
        xx
    }

    walls: none
    lay: none
    pan: none
    stone: none
    akt-falling: none
    stoning: none
    pause: no
    points: 0
    points-pane: none
    level: 1
    preview: none
    start-button: none
    new-start: func [/local ex col rnd] [
        if not empty? preview/pane [hide preview/pane/1 insert pan/pane akt-falling: preview/pane/1 clear preview/pane ]
        insert preview/pane make pick walls random length? walls []
        preview/pane/1/parent-face: preview
        ex: preview/pane/1/pane
        col: poke 200.200.200 random 3 0
        col: poke col random 3 0
        forall ex [
            change ex make first ex compose/deep [effect: [gradient 1x1 (col) (col / 2)]]
        ]
        preview/pane/1/rotate/norot
        preview/pane/1/offset: preview/size - preview/pane/1/size / 2
        if not akt-falling [new-start exit]
        akt-falling/parent-face: pan
        akt-falling/offset: field-size * 1x0 / 2 - 1x0 * stone/size
        points: points + level
        show [points-pane preview pan akt-falling]
    ]
    init: func [/local ex] [
        walls: copy/deep [[]]
        akt-column: akt-row: 1
        layout [
            stone: image (stone-size) 200.200.0 effect [gradient 1x1 200.200.0 100.100.0]
        ]
        if not parse/all stones [newline tabs some [end-up | no-stone | one-stone | new-row | new-wall]]
            [make error! [user message "parse error"]]
        forall walls [
            layout [
                ex: box 100x100 with [
                    old-pos: none
                    rotate: func [/norot /local minx miny maxx maxy] [
                        foreach face pane [
                            if not norot [face/offset: reverse face/offset * -1x1]
                            if none? minx [
                                minx: face/offset/x
                                miny: face/offset/y
                            ]
                            minx: min minx face/offset/x
                            miny: min miny face/offset/y
                        ]
                        maxx: maxy: 0
                        foreach face pane [
                            face/offset/x: face/offset/x - minx
                            face/offset/y: face/offset/y - miny
                            maxx: max maxx face/offset/x
                            maxy: max maxy face/offset/y
                        ]
                        size: stone/size + to-pair reduce [maxx maxy]
                    ]
                    poses: func [/local out] [
                        out: make block! length? pane
                        foreach face pane [
                            append out offset + face/offset + face/size
                        ]
                        out
                    ]
                    legal?: func [/local val out] [
                        out: make block! length? pane
                        foreach val out: poses [
                            if any [
                                val/x > pan/size/x
                                val/y > pan/size/y
                                val/x < stone/size/x
                                val/y < stone/size/y
                                find stoning val
                            ] [
                                restore-pos
                                return false
                            ]
                        ]
                        save-pos
                        out
                    ]
                    del-line: func [num /local pos changed maxy] [
                        foreach pos poses [
                            either pos/y = num [
                                remove pane
                                changed: yes
                            ] [
                                if pos/y < num [changed: yes pane/1/offset/y: pane/1/offset/y + stone/size/y]
                                pane: next pane
                            ]
                        ]
                        pane: head pane
                        if changed [
                            maxy: 0
                            foreach p pane [
                                maxy: max maxy p/offset/y
                            ]
                            size/y: maxy + stone/size/y
                            show self
                        ]
                    ]
                    save-pos: func [] [
                        old-pos: make block! 2 + length? pane
                        repend/only old-pos [offset size]
                        foreach face pane [
                            repend/only old-pos [face/offset]
                        ]
                    ]
                    restore-pos: func [/local pos] [
                        if not old-pos [exit]
                       
                        set [offset size] first old-pos
                        pos: next old-pos
                        foreach face pane [
                            face/offset: pos/1/1
                            pos: next pos
                        ]
                    ]
                ]
            ]
            ex/pane: copy []
            foreach pos first walls [
                append ex/pane make stone [offset: pos - 1x1 * stone/size]
            ]
            change walls ex
            stoning: copy []
        ]
        walls: head walls
        lay: layout [
            backdrop effect [gradient 1x1 100.100.100 0.0.0]
            panel 0.0.0 effect [gradient 0x1 100.0.0 0.80.0] edge [color: gray size: 1x1] [
                size (field-size * stone/size)
                sens: sensor 1x1 rate 2 feel [
                    engage: func [face action event /local tmp] [
                        switch action [
                            time [
                                if pause [exit]
                                if akt-falling [
                                    akt-falling/offset: akt-falling/offset + (stone/size * 0x1)
                                    if not akt-falling/legal? [
                                        show akt-falling
                                        append stoning tmp: akt-falling/legal?
                                        check-lines
                                        new-start
                                        if not akt-falling/legal? [akt-falling: none start-button/text: "Start" show start-button]
                                        eat-queue
                                        exit
                                    ]
                                    show akt-falling
                                ]
                            ]
                        ]
                    ]
                ]
            ]
            return
            banner "REBtris"
            vh1 "Frank Sievertsen" with [font: [size: 12]]
            panel 0.0.0 [size (stone/size * 5x4) ]
            style button button with [effect: [gradient 1x1 180.180.100 100.100.100]]
            start-button: button "Start" [
                either akt-falling
                    [start-button/text: "Start" show start-button akt-falling: none]
                    [sens/rate: 2 show sens start-button/text: "Stop" show start-button pause: no points: 0 if points-pane [show points-pane] clear pan/pane clear stoning show pan new-start]
            ]
            button "Pause" [pause: not pause]
            vh1 "Level:"
            level-pane: banner "888" feel [
                redraw: func [face] [face/text: to-string level]
            ] with [font: [align: 'left]]
            vh1 "Points:"
            points-pane: banner "88888888" feel [
                redraw: func [face /local mem tmp] [
                    mem: [1]
                    if mem/1 < (tmp: to-integer points / 1000) [level: level + 1 show level-pane sens/rate: level + 1 show sens]
                    mem/1: tmp
                    face/text: to-string points
                ]
            ] with [font: [align: 'left]]
        ]
        lay/feel: make lay/feel [
            detect: func [face event] [
                if event/type = 'down [system/view/focal-face: none]
                event
            ]
        ]
        pan: lay/pane/2
        if not pan/pane [pan/pane: copy []]
        preview: lay/pane/5
        if not preview/pane [preview/pane: copy []]
        remove find pan/pane sens
        insert lay/pane sens
    ]
    check-lines: func [/local lines full tmp pos] [
        lines: head insert/dup make block! field-size/y 0 field-size/y
        full: copy []
        foreach e stoning [
            e: e / stone/size
            poke lines e/y tmp: (pick lines e/y) + 1
            if tmp = field-size/x [append full e/y]
        ]
        sort full
        foreach e full [
            foreach face pan/pane [
                face/del-line e * stone/size/y
            ]
            pos: pan/pane
            forall pos [
                while [all [not tail? pos empty? pos/1/pane]]
                    [hide pos/1 remove pos]
            ]
            points: 100 + points
            show points-pane
        ]
        clear stoning
        foreach face pan/pane [append stoning face/poses ]
    ]
    akt-column: akt-row: 1
    tabs: [some "^(tab)"]
    end-up: [newline tab end]
    no-stone: [" "
        (akt-column: akt-column + 1)
    ]
    one-stone: ["x"
        (append/only last walls to-pair reduce [akt-column akt-row])
        (akt-column: akt-column + 1)
    ]
    new-row: [newline tabs
        (akt-row: akt-row + 1)
        (akt-column: 1)
    ]
    new-wall: [newline newline tabs
        (akt-row: akt-column: 1)
        (append/only walls copy [])
    ]
    eat-queue: func [/local port] [
        port: open [scheme: 'event]
        while [wait [port 0]] [error? try [first port]]
        close port
    ]
]
insert-event-func func [face event] bind [
    if all [
        event/type = 'key
        not system/view/focal-face
        find [up down left right #"p"] event/key
        akt-falling
        (not pause) or (event/key = #"p")
    ] [
        switch event/key [
        left     [akt-falling/offset: akt-falling/offset - (stone/size * 1x0)]
        right   [akt-falling/offset: akt-falling/offset + (stone/size * 1x0)]
        down     [akt-falling/offset: akt-falling/offset + (stone/size * 0x1)]
        up   [akt-falling/rotate]
        #"p"     [pause: not pause]
        ]
        akt-falling/legal?
        show akt-falling
        return none
    ]
    event
] in rebtris 'self
if any [not system/script/args empty? form system/script/args] [
    random/seed now
    rebtris/init
    view rebtris/lay
]

No comments:

Post a Comment