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
]

Thursday 30 August 2012

Mine-Sweeper game

Here a classic game: Mine-Sweeper.
You have to find where are the hidden mines: left click try to say that it's safe, right click you sign where are the mines. Numbers give you a hint of how many mines are around the block (also diagonally).
Here the source:

REBOL [
    Title: "Mine-Sweeper"
    Author: "Allen Kamp"
    Email: allenk@powerup.com.au
    Version: 1.0.5
    File: %mines.r
    Date: 1-Jul-2000
    Purpose: {Mine-sweeper for REBOL/View beta2}
    Notes: {Still need to add a menu for game layout choices}
    History: [
    1.0.4 28-Mar-2001 {Starting to cleanup for Link}
  ]
    Usage: {
            Left Click         to clear square
            Right Click       to mark as a Mine  
          }
]
set 'as-pair func [x y][to-pair reduce [x y]]
mine-sweep: make object! [
    ;---------------
    ; Parameters
    ;---------------
   
    ;--- Change these as you wish. Display will size to suit.
    ;--- Be Warned! Too Large numbers will cause a stack overflow.
    ;     note the comments on valid numbers
   
    rows: 9     ; any number 1 or above
    columns: 9 ; any number 9 or above
    mines: 10 ; any number less than rows * columns
   
    ;--- A few checks.
    if columns < 9 [columns: 9]
    if rows < 1 [rows: 1]
    if mines > (rows * columns) [mines: (rows * columns) - 1]
   
   
    ;----------------
    ; Globals
    ;----------------
   
    grid-size: as-pair rows columns
    mines-flagged: 0
    mines-found: 0
    game-over: false
    game-started: false
    last-time: none
    cleared-count: 0
   
   
    ;----------------------
    ; Gameplay Functions
    ;----------------------
   
    patterns: [
        -1x-1 0x-1 1x-1
        -1x0         1x0
        -1x1   0x1   1x1
    ]
   
    square-index: func [rc [pair!]][
        either all [rc/x <= rows rc/y <= columns rc/x > 0 rc/y > 0][return ((rc/y - 1) * rows) + rc/x ][return none ]
    ]  
   
   
    sweep: func [rc [pair!] /local index][
      index: square-index rc
      if all [not marked? rc
              not mine? rc
      ][
              grid/pane/:index/gui-state: 'cleared
              cleared-count: cleared-count + 1
              grid/pane/:index/data: not grid/pane/:index/data
              show grid/pane/:index
              if alone? rc [
                  foreach pattern patterns [
                      sweep rc + pattern
                  ]
              ]      
      ]
    exit
    ]
   
   
    marked?: func [rc [pair!] /local index state][
        if none? index: square-index rc [return true]
        state: grid/pane/:index/gui-state
        any [
            none? index
            same? state 'flag
            same? state 'cleared
        ]
    ]
   
    mine?: func [rc [pair!] /local index][
        if none? index: square-index rc [return false]
        same? grid/pane/:index/content 'X
    ]
   
   
    alone?: func [rc [pair!] /local index][
        index: square-index rc
        same? grid/pane/:index/content 0
    ]
    untouched?: func [face][
        not any [
            same? face/gui-state 'cleared
            same? face/gui-state 'flag
        ]
    ]
   
    make-grid: func [rows columns][
        grid/size: as-pair (columns) * 24 + 8 (rows) * 24 + 8
        repeat column columns [
            repeat row rows [
              append grid/pane make square [
                  offset: as-pair (column - 1) * 24 + 2 (row - 1) * 24 + 2
                  square-id: as-pair row column
              ]
          ]
        ]
    exit
    ]
   
    survey-mines: func [/local column row result rc index][
        repeat column columns [
            repeat row rows [
                rc: as-pair row column
                index: square-index rc
                result: 0
                if not mine? rc [
                    foreach pattern patterns [
                        if mine? rc + pattern [result: result + 1]
                    ]
                    grid/pane/:index/content: result
                    if not zero? result [grid/pane/:index/f-colour: pick colors result]
                ]
            ]
        ]
    ]  
       
   
    place-mines: func [rows columns mines /local mines-placed location grid-size][
        random/seed now
        mines-placed: 0
        grid-size: rows * columns
        while [mines-placed <> mines][
            location: random grid-size
            if not same? grid/pane/:location/content 'X [
                grid/pane/:location/content: 'X
                mines-placed: mines-placed + 1
            ]      
        ]  
    ]
   
    show-mines: func [][
        foreach square grid/pane [
          if same? square/content 'X [
              square/gui-state: 'cleared
              show square
          ]  
        ]
    ]
   
    new-game: func [/reset /local gp][
        if reset [
        gp: grid/pane
            repeat i length? gp [
                gp/:i/content: 0
                gp/:i/gui-state: 'covered
                gp/:i/font/color: 0.0.0
                gp/:i/f-colour: 0.0.0
                gp/:i/color: 170.170.170
                gp/:i/data: off
                gp/:i/away: off
               
            ]
        show gp
            status/text: mines
            time/text: "0000"
            last-time: none
            mines-found: mines-flagged: cleared-count: 0
            game-started: game-over: false
            show [status time]
        ]
          place-mines rows columns mines
          survey-mines
    ]
   
    ;------------------
    ;     Gui
    ;------------------
   
    ;--Images
   
    smiley: load to-binary decompress 64#{
    eJxz8n3BwgAGZkCsAcQiUMzIIMEAA0LcEAwDB2gAGFABabr+/0dBRJiARReqCWRq
    xK0dXSMawKsdRQFW/+LQS0AjXu1E+RSHsweLXrSwJRTU+BRjcMlJGMQnD6I1EqWd
    mOxAVj5CN4HE/EsfwMAAAKQP0/PoBAAA
    }

   
    ohoh: load to-binary decompress 64#{
    eJxz8n3BwgAGZkCsAcQiUMzIIMEAA0LcEAwDB2gAGFABabr+/0dBRJiARReqCcRq
    hANC2tHVNDRARYAAyMarHYulWNkYerF4E4+9qNqxBxFW/xKpl7gAp5peiE+R/Ygp
    giu4ML2JJoInjgjaS0zyoDBZEq0RoZ2sfIRuAgwQqYs+gIEBAG5tvhXoBAAA
    }

   
    sad: load to-binary decompress 64#{
    eJxz8n3BwgAGZkCsAcQiUMzIIMEAA0LcEAwDB2gAGFABabr+/0dBRJiARReqCWRq
    xK0doRGXCUgK8FmK1b84rMYVOAiA2+VE+XQw64WwCYlQJZyxxC8ee/EnDxLTFVHa
    ickOZOUjdBNIzL/0AQwMAExLz/foBAAA
    }

   
    sunnies: load to-binary decompress 64#{
    eJxz8n3GwgAGZkCsAcQiUMzIIAEW3wCUP8IHwTBwgAaAARWQpuv/fxREhAlYdKGa
    QKZG3NrRNaIBvNpRFGD1Lw69RLkWh9WU6oVrb2pB9yMEAMWxxRdUJZxEDiJMLi43
    YwYv1gDHFVx4ADFxRHnyoG6yJCY7YJqAGi9EmQADROqiDwAAF9WiUeYEAAA=
    }

   
    colors: [
        0.0.255   ;- 1 Blue
        0.240.0   ;- 2 Mid Green
        255.255.0 ;- 3 Yellow
        0.0.139   ;- 4 Dark Blue
        0.100.0   ;- 5 Dark Green
        100.0.0   ;- 6 Dark Red
        0.255.255 ;- 7 Aqua
        255.0.0   ;- 8 Red
   
    ]  
   
    grid: make face [offset: 24x48 pane: [] size: 200x200 edge: make edge [effect: 'ibevel]]
   
    square: make face [
        offset: 24x0
        size: 24x24
        text: none
        font: make font [style: 'bold size: 14]
        color: 170.170.170
        edge: make edge [
            color: 190.190.190
            effect: 'bevel
        ]
        effect: [gradcol 1x1 140.140.140 100.100.100]
        square-id: none
        content: 0
        gui-state: 'covered
        data: off
        right-down: false
        away: false
        f-colour: 0.0.0
        feel: make feel [
            redraw: func [face][
                face/text: to-string switch face/gui-state [
                    covered [""]
                    flag [face/font/color: 255.0.0 "!"]
                    query [face/font/color: 0.0.200 "?"]
                    cleared [face/font/color: face/f-colour
                            either face/content = 0 [copy ""][face/content]]
                ]
                face/edge/effect: pick [ibevel bevel] face/data
                        ]
            engage: func [face action event /local result][
                if game-over [exit]
   
                if action = 'alt-down [
                    ;Toggle Markers
                    face/right-down: true
                    result: switch face/gui-state [
                        covered [
                            mines-flagged: mines-flagged + 1
                            if mine? face/square-id [mines-found: mines-found + 1]
                            'flag
                        ]
                        flag [
                            mines-flagged: mines-flagged - 1
                            if mine? face/square-id [mines-found: mines-found - 1]
                            'query
                        ]
                        query ['covered]
                            cleared ['cleared]
                        ] face/gui-state: result
                ]
   
                if action = 'down [
                    if untouched? face [
                        face/data: true
                        face/away: false
                        start/image: ohoh
                        show [face start]  
                    ]
                ]            
           
                if action = 'away [
                    if untouched? face [
                        face/data: false
                        face/away: true
                        start/image: smiley
                        show [face start]
                    ]
                ]
   
                if action = 'alt-up [face/right-down: false ]            
   
                if action = 'over and not face/right-down [
                    if untouched? face [
                    face/data: true
                    face/away: false
                    start/image: ohoh
                    show [face start]
                    ]
                ]
   
                if (action = 'up and not face/away) [
                    game-started: true
                    if untouched? face [
                        if face/data [face/data: false]
                        ; or mined
                        either same? face/content 'X [
                            face/data: not face/data
                            face/gui-state: 'cleared
                            face/color: 255.0.0
                            face/font/color: 0.0.0
                            start/image: sad
                            game-over: true
                            ;--show where mines were hidden
                            show start
                            show-mines
                           
                        ][
                            sweep face/square-id
                            start/image: smiley
                            show start
                        ]
                    ]
                ]
               
                ; Update Scores and Game status, redraw
                if any [action = 'alt-down action = 'up][
                    if not game-over [status/text: mines - mines-flagged]
                    if all [
                        mines-found = mines
                        (cleared-count + mines-found) = (rows * columns)
                    ][
                        start/image: sunnies
                        game-over: true
                        show start
                    ]
                    show face
                    show status
                ]
            ]
        ]
    ]
   
    ;------------------
    ;   Panel Gui
    ;------------------
   
    status-panel: make face [
        offset: 24x10
        size: 219x30
        edge: make edge [effect: 'ibevel]
        color: image: none
        pane: reduce [
            status: make face [
                offset: 1x1
                text: mines
                size: 54x24
                font: make font [color: red style: 'bold size: 16 align: 'right]
                color: black
                edge: make edge [effect: 'ibevel size: 2x2]
            ]
            start: make face [
                size: 25x25
                offset: 96x0
                image: smiley effect: [key 192.192.192 gradcol 1x1 1.170.170 0.100.100]
                feel: make feel [
                    redraw: func [face][
                        face/edge/effect: pick [ibevel bevel] face/data
                    ]
                    engage: func [face act evt][
                        act: switch/default act [
                            down [on]
                            over [on]
                            up [if face/data [do face/action] off]
                        ][off]
                        if act <> face/data [
                            face/data: act
                            show face
                        ]
                    ]
                ]
                data: off
                action: [new-game/reset self/image: smiley show self]
            ]
           
            time: make status [
                text: "0000"
                offset: 159x1
                feel: make feel [
                    redraw: func [face][
                        redraw: none
                        show face
                    ]
                    engage: func [face action event /local i][
                        if any [game-started = false game-over = true][exit]
                        if last-time <> now/time [
                            last-time: now/time
                            i: form 1 + to-integer face/text
                            while [4 > length? i] [insert i "0"]
                            face/text: i
                            show face
                        ]
                    ]
                ]
                after: none
                rate: 1
            ]
   
        ]
    ] ;end of status-panel
   
   
    ; Generate the Grid
    make-grid rows columns
    new-game
   
    board-size: as-pair grid/size/x + 24   grid/size/y + 60
   
    main-face: make face [
        color: 180.180.180
        size: board-size
      pane: reduce [
            make status-panel [offset/x: (board-size/x / 2) - (status-panel/size/x / 2)]
            make grid [offset/x: (board-size/x / 2) - (grid/size/x / 2)]
        ]
    ]
]
view center-face mine-sweep/main-face

Monday 27 August 2012

Carl Sassenrath announce

I report here Carl announce, you can comment it or send Carl a feedback to: http://www.rebol.com/article/0510.html
I've been quiet for a long while, and this blog is not easy for me to write.
I'm sitting here with a glass of 2010 Merlot from right out of the barrel... hoping to be inspired on how to write this. But it's difficult, and the 2010 and 2011 vintages aren't very inspiring either. They were troubled by cooler than usual summer temperatures. They lack body and character.
I find myself thinking back to when I began growing grapes and making wine, which seems like a long time ago, and it strikes me that I've been working on REBOL even longer. For more than a decade REBOL has been a labor of love. As a blend of theory, experimentation, and invention, the language embodies elegant and wonderful concepts and properties. It was and is the most productive language I've ever used. I hope your experience has been similar.
I still care a lot about REBOL and its future.
As you know, REBOL began as a commercial venture. But, times have changed, technology has changed, and economies have changed. The old model of how proprietary software products make money has been turned inside-out. And, it's even more difficult to make money in the computing language market. There are so many competitors, most of which are free, most of which are open, and many of which are quite well supported.
So, it's come time to consider the next stage in the future of the REBOL language. I'll tell you that I've not reached any final conclusions. I want to solicit your suggestions and ideas first.
I also need to tell you that I don't have much time to help out with whatever the REBOL future may be. I can help a little from time to time, but generally I'm very busy these days. Since the end of 2010 I've been working with an amazing company and a world class team building some really great products. I must admit that I'm quite addicted to it. I hope to say more in a future blog.
Anyway, I invite you to post your comments below, but here are some pointers to keep in mind:
  1. My time is very limited, so please make your postings relevant and on point. If your post gets to be long and drawn out, I'm probably not going to read beyond the first few lines.
  2. Keep in mind that REBOL is more than just a technology, it's also a community, and all of us have different interests or requirements. If you're a doctor using REBOL in the medical profession, your needs will be quite different from a university research scientist. That's fine. This is a brainstorming session.
  3. Let's keep this discussion within the REBOL community for now. I don't care much about what people who don't know REBOL say or want. They don't understand REBOL, and many never will. This is our thing, we should guide it where we want it to go.
  4. I cannot afford the time, energy, or heartbreak of looking backwards. Yes, REBOL has invented some very cool software technology. Much of it was years ahead of alternatives. But, what's done is done. That's the past; we cannot change it. I want to focus on the future.
  5. Please don't post negative or degrading comments. They will be removed.
If you know REBOLers who might be interested in this discussion, please let them know about this blog posting.
I look forward to hearing from you,
-Carl