Friday 27 September 2013

Roman-Arabic numeral converter

Today script is simple but efficient, is a Roman to Arabic (our common) numeral, it converts in both directions:

Roman 10
== "X"
>> Roman 115
== "CXV"
>> Roman 418
== "CDXVIII"
>> Roman "XIV"
== 14
>> Roman "XXIV"
== 24
>> Roman "IX"
== 9
>> Roman "LXXXI"
== 81
>> Roman "MCMLII"
== 1952
>> Roman "MMI"
== 2001
>> Roman "MMMCMXCIX"
== 3999
>> Roman 9
== "IX"
>> Roman 81
== "LXXXI"
>> Roman 1952
== "MCMLII"
>> Roman 2001
== "MMI"
>> Roman 3999
== "MMMCMXCIX"


Here is the source code:
REBOL [
    Title: "Roman"
    Date: 3-Jul-2002
    Name: 'Roman
    Version: 1.0.0
    File: %roman.r
    Author: "Andrew Martin"
    Purpose: "Converts a Roman numeral to Arabic and reverse!"
    eMail: Al.Bri@xtra.co.nz
    Web: http://valley.150m.com
    Acknowledgements: {Christian "CHE" Ensel}
]
Roman: function [
    {Converts a Roman numeral to Arabic and reverse!
    Returns 'none if it can't convert the number.}

    [catch]
    Number [string! integer!] {The Roman "MMMCMXCIX" or Arabic 3999 number to convert.}
    ][Roman-Arabic Result ][
    throw-on-error [
        Roman-Arabic: compose [
            M   1000
            CM   (-100 + 1000)
            D   500
            CD   (-100 + 500)
            C   100
            XC   (-10 + 100)
            L   50
            XL   (-10 + 50)
            X   10
            IX   (-1 + 10)
            V   5
            IV   (-1 + 5)
            I   1
            ]
        either string? Number [
            Result: 0
            if not parse/all Number [
                0 3 ["M" (Result: Result + Roman-Arabic/M)]
                opt [
                    "CM" (Result: Result + Roman-Arabic/CM)
                    | "D" (Result: Result + Roman-Arabic/D)
                    | "CD" (Result: Result + Roman-Arabic/CD)
                    ]
                0 3 ["C" (Result: Result + Roman-Arabic/C)]
                opt [
                    "XC" (Result: Result + Roman-Arabic/XC)
                    | "L" (Result: Result + Roman-Arabic/L)
                    | "XL" (Result: Result + Roman-Arabic/XL)
                    ]
                0 3 ["X" (Result: Result + Roman-Arabic/X)]
                opt [
                    "IX" (Result: Result + Roman-Arabic/IX)
                    | "V" (Result: Result + Roman-Arabic/V)
                    | "IV" (Result: Result + Roman-Arabic/IV)
                    ]
                0 3 ["I" (Result: Result + Roman-Arabic/I)]
                end
                ][Result: none ]
            ][
            if all [0 <= Number Number <= 3999] [
                Result: make string! 10
                foreach [Roman Arabic] Roman-Arabic [
                    while [Arabic <= Number][
                        append Result Roman
                        Number: Number - Arabic
                        ]
                    ]
                ]
            ]
        Result
        ]
    ]

Tuesday 24 September 2013

Reversi / Othello game

Here again an Othello (or Reversi) like game:


You can ply against the computer or against another player.
Here is the source code:

REBOL [
    Title: "Reversi"
    Date: 27-Mar-2006
    Version: 2.3.0
    File: %reversi.r
    Author: "Vincent Ecuyer"
    Purpose: "Reversi / Othello"
    Usage: {
        ===English
        Classic Reversi / Othello game.
        It's a two players board game, where the objective is to cover the
        board with the greatest number of pieces of your chosen color.
        The first four pieces must be placed at the center of the plate,
        then the normal game begins.
        At each turn, each player puts a two faced piece on the board -
        all adjacent opponent pieces between the new one and the ones on the
        board are reversed to match the player color:
        right after the start:               after more turns: (two diagonals
        (one horizontal line reversed)       and one vertical lines reversed)
        . . . . . . . .   . . . . . . . .     . . . . . . . .   . . . . . . . .
        . . . . . . . .   . . . . . . . .     . . . X . . . .   . . . X . . . .
        . . . . . . . .   . . . . . . . .     . . . X v X . .   . . . X O X . .
        . . . O X v . . > . . . O O O . .     . . X X X X . . > . . X O O O . .
        . . . X O . . . > . . . X O . . .     . . X X X X O . > . . O X O X O .
        . . . . . . . .   . . . . . . . .     . O O O O O X .   . O O O O O X .
        . . . . . . . .   . . . . . . . .     . . . . . . . .   . . . . . . . .
        . . . . . . . .   . . . . . . . .     . . . . . . . .   . . . . . . . .
        If it doesn't reverse opponent pieces, you can't place a piece on the
        board - you must skip your turn.
        The game ends when the board is fully covered, or when both players
        can't puts pieces on the plate anymore.
        This script allows you to play against another player or a basic AI .
        If the game starts in french, change the first code line from
            language: 'francais
        to
            language: 'english
        .
        ===Français
        Le jeu Reversi, aussi appelé Othello.
        C'est un jeu de plateau pour deux joueurs, où l'objectif est de
        couvrir le plateau avec le plus grand nombre de pièces de votre
        couleur.
        Les quatre premières pièces doivent être placées sur les cases du
        centre du plateau, puis la partie normale commence.
        Dans un tour, chaque joueur place une pièce à deux faces sur le
        plateau - toutes les pièces adjacentes de l'adversaire situées entre
        la nouvelle pièce et les pièces déjà placées sont retournées pour
        présenter la couleur du joueur:
        juste après le début:                 plus tard dans la partie: (deux
        (une ligne horizontale retournée)diagonales et une colonne retournées)
        . . . . . . . .   . . . . . . . .     . . . . . . . .   . . . . . . . .
        . . . . . . . .   . . . . . . . .     . . . X . . . .   . . . X . . . .
        . . . . . . . .   . . . . . . . .     . . . X v X . .   . . . X O X . .
        . . . O X v . . > . . . O O O . .     . . X X X X . . > . . X O O O . .
        . . . X O . . . > . . . X O . . .     . . X X X X O . > . . O X O X O .
        . . . . . . . .   . . . . . . . .     . O O O O O X .   . O O O O O X .
        . . . . . . . .   . . . . . . . .     . . . . . . . .   . . . . . . . .
        . . . . . . . .   . . . . . . . .     . . . . . . . .   . . . . . . . .                                                           .......   ........
        Vous devez retourner des pions de l'adversaire à chaque coup - si
        c'est impossible vous passez votre tour.
        La partie se termine lorsque le plateau est recouvert où lorsque aucun
        joueur ne peut placer de pion.
        Ce script vous permet de jouer contre un autre joueur où contre une
        AI basique.
        Pour jouer en français, changez la première ligne de code de
            language: 'english
        en
            language: 'francais
        .
    }
    Library: [
        level: 'advanced
        platform: 'all
        type: 'game
        domain: [gui vid game]
        tested-under: [
            view 1.3.2.3.1 on [Win2K]
            view 1.2.1.1.1 on [AmigaOS30]
            view 1.2.1.3.1 on [Win2K]
        ]
        support: none
        license: 'gpl
        see-also: none
    ]
    History: [
        1.0.0 26-7-2001
            "Première version jouable"
        2.0.0 15-5-2002
            "Première version publique. Refonte du moteur et ajout du niveau de difficulté"
        2.1.0 2-2-2004
            "Nettoyage du code pour View 1.3 et amélioration du redimensionnement."
        2.2.0 28-1-2005
            "Plus de libertés pour le redimensionnement."
        2.3.0 27-3-2006
            "Refonte de l'interface."
    ]
]
; ===Localisation

; choix de la langue/language selection (actuellement, 'francais ou 'english)
language: 'english
; textes de l'application
locale-strings: [
    francais [
        doc [
            usage {
Le jeu commence en mode deux joueurs.
Le premier bouton indique le mode de jeu actuel,
et permet de le modifier.
Le second règle le niveau de difficulté:
    - minimum : un des trois meilleurs coups trouvés est joué
    - moyen   : un des deux meilleurs coups trouvés est joué
    - maximum : le meilleur coup trouvé est joué
}

            usage-title "Utilisation"
            usage-close "(cliquez sur la fenêtre pour la fermer)"
        ]
        mode [
            human-human "2 joueurs"
            computer-white "Ordinateur joue blancs"
            computer-black "Ordinateur joue noirs"
        ]
        level [min "Minimum" med "Moyen" max "Maximum" ]
        button [skip "Passer le tour" end "Fin de la partie" ]
        score [
            draw "Egalité"
            white "Joueur blanc gagnant"
            black "Joueur noir gagnant"
        ]
    ]
    english [
        doc [
            usage {
The game starts in two players mode.
The leftmost button shows the current mode,
and allows to change it.
The second button controls difficulty:
    - minimum : one of the three best moves is played
    - medium   : one of the two best moves is played
    - maximum : the best move is played
}

            usage-title "Usage"
            usage-close "(click on this window to close it)"
        ]
        mode [
            human-human "2 Players"
            computer-white "Computer plays light"
            computer-black "Computer plays dark"
        ]
        level [min "Minimum" med "Medium" max "Maximum" ]
        button [skip "Skip turn" end   "End game" ]
        score [
            draw "Draw game"
            white "Light Wins"
            black "Dark Wins"
        ]
    ]
]
; fonction de localisation
locale: func [
    "Sélectionne la chaîne dans la langue courante."
    'name [word! path!] "Nom de la chaîne"
    /local r
][
    r: locale-strings/:language
    foreach i :name [r: r/:i]
]
; ===Aspect visuel

; motif de fond du plateau
; (ici, le motif %wood1.pat de GIMP, avec l'effet [colorize 170.100.70])
fond.png: load 64#{
iVBORw0KGgoAAAANSUhEUgAAAGAAAABgCAIAAABt+uBvAAAAE3RFWHRTb2Z0d2FyZQBSRUJ
PTC9WaWV3j9kWeAAAE1pJREFUeJx9nE2r7FoRhtcfEUFE5MJFRRQRlQuCKCiIgijoxNGe9CS
jTDLJqCd74siJ/9WcXSfPedZbqy+EJp3O+qp6662PrM7Yf/eT7bc/uo7HN1/XcZ1fF48//PT
6rF+vi2+//qp+rYt1w/nHn11H3Vmt6IQb+HTD+vrvX/6wjqvzOrinpkQnzz//ojqhra/X9K6
L1zlz+PtPv39ddD/VkClVWw6W4ytXP8MCKilUd9Uvv/qrx7OwkJQFzc0sjJO64fos6VySokk
/PFwMWtOrnumtrpQg6nj/6y+RcknKYnJz42DE+kPPrLmWzc29lUUGjqoJXXl+XDFIjdOYwFJ
Y14nXz2rrpD6Nyqv/QKKtp0b3WNf5FwHRrARpyAVe6NHL8FEyQpPL3jqsriYXiP718x9Y/3F
Pb2hEcx64CDZAMTXidQCZrvJhQfqHEE0nKZsbd4L5GruWGoTVJ42ALunUdGOi5o5gjfrpkgi
KwXID5kv+shmGQOtzBMtaPwEZIyIWUDPmCtJBM68EVLxQHdrEuoxozmI4AQ5FZDXJV2hlRa9
AHToY0bhLhzZLMccAqC6ksxSQoV7Lo6GdqduGo6lZ2aLLnQXNeTg7r1gRhGiCH6YM02oHsyU
VjMhXxuvw7g4VgeLFunS8mCUfVfNqu9Srxwpa2FfxhIf4RNJhSmGry8FwHAa5ryB0i9v9Y7b
Xwq6A5TqgHjNI+ITuT2KR9krFvrbTujnQhO/voVbdPAKxYT7VRQEkjB/UhElCQ3WE5deoOKx
LNNdnd66WC9xn2wmwBBjpkFWADk/Yird6LNPRDdsrtLmBuleuwb6D8RwrY0TXiTHvwyQNWPb
ZeQdxWC52fNWEz85fYX2Br4mDuqH1iKBPzgrBidRR4UxwrWffLQiSNgqWDG0PbYY2lZSLLAq
Hv0LNCNTWxyTLSkY3E3OEvYPdfLcmc0FQbIi7pBDMElTiJsHNYWK+rZPucQe9gNpChDr8NZQ
3gDT6r2ito90r8cLCQcTCYjFWnZ1RJy97tLq/O8FTwZf7D/YJQSC4WIW5jHmObbZ/prWMR7w
M31Ba6nPdV/6IHvY7Pt4VudmcrdhDaZe9Z1G+idzMUifVw/UZJG1/V7BwHF+fw/g0e3/Lgq2
fKBrEYbLotBU9L2OI7j2DE8JOGaXEYdssOretwHTdMgDyiGFiMXHsd7LTnW6wWAQmRlMkE2F
l4SIti/POvIxoMtvtI72AXzmvTyQSBGpW9rSRyeiuLhgncBSOEGl6yH6E/jvuiK0wKGveQjw
VVRvUmHl3lxigA8uAXsRBLHB0cBqZPXpciqBHmN03v5LL8uZjjiqswjIfQylEw2TIhMvnlIB
i2ksy4fOoSHo5yyBX7HOZc3ebAqUhbkfh/fw/f/tV8A4oCKztH9ENUHJa73iypHMRcLia7c6
KN8WiIe7PCAqisuV3THkYW439aB2RnZjCSsR4DQcWx+2qaH6dXFL77z9+g/hgX0Ps+onUp4D
j1DfwEm1LKD5H3584qN9tnXcShS8D/3GEMy5y8TKiFeTidNfRaXVyKG/wMsKCqvZGbF0mWX3
C3917WKBoesSaWbnJZemqg6SXzB199oANYgahtkcjn6/uNnyo82fuXwYBofJtrjh78lOqERP
qtBrU0MezKfXqp20TIbowsARpgBEoIVlARw9x8bqtjDQSehOF2d3R7+fHPj32D0V1WwuhmNg
AoG/A0EyijEJbBGSslW0SEJuPWbYX7yVU2473CDjtXjztYU61aVhGHpLBOpTsJiPEIH41rNz
WznVfxWLL/pnAeacUFkRoN752YFr3nHzhIBbZ491NqXCk9dzZqxxxf/1aDovw14MeNzE7GUS
l6Knu7KUf5BXajRjHCLCaTV6WyVQP8nQ70dhKGQMB0RDIRL4Tdlrgx69hO2VKNqjgdRsav1p
2IL2Oi30qPkAiEZSE+w4LHf5uSZmbYE1TgP2laxThO6NnjvLB4T4obtBDhKP7HEAzMTgI8dm
U/EzBQaxX98qdjUiRELxjlr1FDSHHGMBDeodCT+U4dxgNLTKT//3zG6dpwcfn/fCn5F4PAmz
p21y6DYzUEHaXXv70XMymSAC67Lev0LCKMCrsdLsripue2DgpMUMHVe9KO+y2ERy8Y6GcL2J
aC6VjvI5hw9n16NYFLa6UG3LNGC1FzXxZjQz52s1zYhRHEGQpPOfHZC481mR2VfUQMbrf9Gj
wWwKuk0DR5dildwy/HrzjSruPyrn6c8E6IQWzs8cSOymY2vgJ+ZKOIEE7pqcqk8DHruC4o4S
SI+r5sj+IdOb8eEh0znWpkEWv43WLqwFQndUVGsPymW4d1mSPcezjbYBkm0C715ED2uETYPH
ryoi1Ic7eOCLAGHuba+C7asPdUZ4f5RSTjoMdFIN7crZ5zBk/uDBqwkxCExVehHFdV8472jR
nj5BZuBs7qU3psm3NsY9DHgPQnhULet5Ze48eXsGtUzJoqm5ZXpQNzAnm4EPbRTZtYoGwRjf
aCMYM7NBMV3gszIpd2hTau8K5qJyFnk3b552I4aSwuG+Bj5mImYMAe4zzDjvO2h/kdbKqiH3
pyLMJKqWtPyNEiF9f2WAEE+HFzVnksdCWcYE0Oz1ZeVdDLkasMMze4bkMP/vUHnH2G+wslio
NfaJ5TIlROuM4kLOhUYSOSkskbvsc6zLPcw6gTgpm1lt1V97H7GNmMdE4xDAi/CtxIDMw7iy
+/aPoZWtysWLXk5+ibawDES8xdcwJR0dudQUTnR95YsU9wxI1FnyEgIxAWi39/XFnWGFotkp
Tqa3PJBgOLuzdPFW3FX3YyqIHeNZGgG0i4utkPF9ErqZSphul+FMBlckeLaHD3qcP7MX6N32
8MtW6DS4nQLGPC6G/WqOF4IbjVFoYrsezMUcsbwsGjYtBVYXeQ3FNzKEkhbAuH7dcnke05l3
i8P1hfUinbuZX9zl8tzPm486ntvmJdZgJlhVR9SsiPNoDDOS4qfLLRYx6VwZgE8beiVzOubY
bA7n/JQjQTckrt+AxPANY0halh7fCadW1gS2EbiPGCQfcoySmWj/VrzbYJVJ6z+FD+/X32kD
Vmd8r6fYSgXJY1q6S+1PR4Cu7CJuP0gxIeZ8zSdjH2A9G86/IsaxvuV76gbDf2WEWs+/hSQ9
5Yp1cCXktNR8UZojRebDSc66ZLpVvg40T4vJwJjEBK6xaDYMlFuMIiiMMmHuWlugpvt/7l5Z
u0fTR7S58XPcGtn0zCHJ/1199zDUGYzjTaju8bDc+VJrCcEj2PBI3HHqSiXs6FXF0pouvLvF
0xYaqohOTSxi4dVazKnOzds+W7n3mIBObf8NVvesB5vtHzoIg7NQCZVUhi6zK6yRa6etxKEj
bCnCteaTv+UNktsGlYTIfi6lLahwtMD2UTLnASC8g1qi5JLJUPtikihQw3PUUMPzDcj2WJkt
CAdhpTTLCzm5fMFT4aPA1oi9W1ZODU7lcZxCioapbI18vAwfH8GZ9Zy3LumXgsZp4bfX8o/x
U0HNdZCYBqOcdH3WGHawnOMxsapI65sLIfhfSTITWM/B0vTkCS5NrcA0sy/WwMk/GCaMBYl/
huoetz9R+qkIyIk4xxk5FjBatCZhzF0CM/+4Xwu4e+nMZBH/O0XD/6qmGSRYHQy4m7/c57wu
+D/ap82E2OZQTuozPDCxmyMKx3Lu2fwEu2A3zdCIecgyuiSUFrdAb9dY4nnMFGhKoZy3HnNP
2UO6ozQuw1KH8K4oJGFfUk8I6HMucqj+UmJiWMUxXx12fNsp8Hj5kKVAU7BQ/cAEl+QphpIG
58+AwIHqqvhMOKJLP97uItywnAZ9DURVaPe+61/v9WMrMdcwVeCPRmfA+VwhdJDDdmBB8A6L
f9QDW+B1gyRgpEHlvxmP+t8Sx2nfEr1a1nwLZUwCf/S4J+tMMjfIiDvBkoomDI+QesbL1EZ4
RQZ9VckXD7y2Kf8rl2zJdA3EN+FVxy2blCLPrPCggjCvUGbbvZ8qeiU0PMo7YB90EuD4nq35
wWiqtNYSrClrxqJ2k9rn8jBk6orFzqEkbg7sqvNZtPIM7VWCLYn6YPDJ1/wGZuG3AqSVLFmP
97/dehljPc86woXNOAh0dDh0Fln6MyJr39gyyH8guNNEDzhLr0aKTz24eUASD7Pfuub61J1i
myz7sK1gwbMQ21b96eabPkLsX/3j90odgul1BrK3bohh2H31CiOm4o8F+z6F3QtimCnRkXg/
tePfN/BMzSrqWrNVuGurk8rzLjFfOgcEGOjphm3kt7utz1OLtU447mvJOTVYeO4Ni9ibdwCY
9b/e+Kf7XeM4uHBEDUodCaGX/iA9C56GDsH0bfpD3MQeNJNXDZnyd10ZUnh3C2bhPxrB0Nj1
63vQ/EQcH+7wf2BuuLGIyD28U8uyhPBw/svP1Hka+3w+Fdv0hAV8E6tmQWxMYb/P7LtBAbXC
qzX6wXUDGjixM3YxAKOAcvX6qIXj/imGIDr3LsW/Z8p8x+YkO0dPb/V4GvsJQ2KCXX7ZyzW3
QoLATG517nYH7HXQA6VP5nhfJRGlVovnLj78HwR1zohSxlZHrJNGhg0NEOjy09dUEb11CgkH
Vnzho0wYBZBz/XjQTBUkjBYvfNuyQcp8Dorrz8fE6rbJrQy/oz7t7mMCm936wfxIRA1j2sJc
yUGqfG+BiiGE4QArVERK1pwBrvZCEKbGSCjgDDgbmpvLbqcQtbLYTDUDY702cNStkXXOLWBm
VID47R1aBsK41jl1Jmj0cHBY5BNmpxVrKdyAXbi4Y3SCyZ+kBhCXFr4/V9lXbi3Mg6JXpUZa
BZIkwIsQ9eH8QOKxKu0WGCJCaj1LdRSUm2nC6Xnkw8a5QzaFT3ImSIZFNOaAlbp7a7ycO1Sp
CM8P/ce8f7ksYQNRxRxCzhejQM9yz+TuSO0vWZuKU+mzJnQk4bJODNwc5XNw/Sq5YwHE/mHV
V6LgfveD1ls5kejZ/KMCJlxxuqpPt839yYq+zO3y2umdEKDE6QVCBP5JSS8oXI4D0zcFlu/5
95BCB+VvlNcPBDLrXMF1hg1gTFotHQLhWeyAxZLfrj3NebWmIyOPRdn2EAhgoRnzoxXEe/VA
kTXgRgKi1TDvMuux3RV9mokjckGx3scF8MJeh0dnamt/md+aE3MOyAl92fHBz19y+qgXWisY
5hx7MG9sOP4J0Y3m2wVJLD4KDd+109jtTC+pxgBYEx1enAc6HjJdOryY1hNtZYsQ7PmgQnpK
p2Fh62cGhkF+8FsEYkAZi9MAf6A8FYnFPJJnIC2X4Tzfohgm7OVNCZGETX/6SaSS/fbzS06Y
Uloi5mXee81MaFvm2+icLtkPYuc1POOwE6cqBZawW9xSVPIsSXXomIdxg5GExd1fniNMjbUp
eOnbML1GNM76IPhyPYJXbx75cHF9498CpnYPZJx4WQslv99+QTBRMxsY4gFmPPo0RrrNnA/I
75o2+OEHzuh3Zdr9tpP8KXzAHRuwc8dSjjqiche13crGJGUFUOdD9KHiHQ7XIzEEhR78pNli
QaZnyCUfPua4MECIa6DnapoTZaDVsg+xCNIfK233C+10hImgaIOox11lehWeeCg35mygewRN
1wzdVKfHiDBTrPFQqBRcRiPbDAUq4zlo8U9rnTQABw2o1PL99rnh3lt3m9Ceu+yfHmSFi48t
LZU7QgXXmIWIsevPaIvIMEgzIh1ntylGGF7Pf/xq+bM3LIBjp4bmRZaZn9v9evf74nP9yEnK
0A4q1BZv0EyNo6XOfemBPV8grNPTJi1XWw/Gnr797HZVPWG+gEQt6m0vLXu1jLkeYnt/a05j
gUSMr5upo82ypnGUKmhzsdBTXZKrVQ3U1XqP6qeQaoOhAOD7+G8K/Xzb9d9Y87dWCDty5MYW
f8nXk2zWJkq0A+2NTuyutHW4WdHn6CwrX8fuvvlP138JHQaRqb19eExgrdNceyWThfK+Hrbs
qO52qH3MlINYcTba51GvAdqo+VN8Jgz3mcmKk8pYAQp9el+zuXvmLfsXzftOrnW0FEeZYCmD
QcINfw8oiUFhO/pwTK9qCLMcZzktMJs97D9CI3r2SoEC7iW7/4QX61K1SE0RfKlKOKL8Pceh
lSFY7RhDKMDk+7qL1+VFof1O13/0PO0Kuvt8vBwkUmCBOxfKntia7NuiauWMTDG0ZcDENM6u
LNU6eEc0+V2bMEsccEIYDheMed+WfXz8JaPnczuZgR/vUo+sOtH50N2yas1tw/ejUJj7zrqn
QiPDLU2w1D9W2mSrXn/e+H8jIEny739M3cNgW264ykEUQlmVyNecFJWMgsSqg3qdI/zZhM5E
tAu1uymls2mZ9hx2xkCDQOr685A2v7BBmiQLjFvu3XIxeTlyLOFuGGTGhh/Bnh4zz0upzu7c
URKyAmGzsSJaAqEiw3k35aX/QPkex27zL3cz6yhFGD4Zbz5KW3qf3trXCFQTkAK07E74GbXP
PNu/pZPIdv6XsAXbe5kcX2IgLg56Evfu3hLmWQqeno1XUYn9AfTrC6gqwDz3vRD9GR9zB63R
oO4DmrmPEIm3AvmhTOudw0W7envi4g0nj3DCBCC2OZfy2z+U6m7Z9y64UNAKLILWwaOs1dP9
/p0+lCkKJWo8AAAAASUVORK5CYII=}

; apparence des jetons (en réalité, des cases)
jeton-effects: [
    noir [
        gradient 1x1 127.127.127 0.0.0
        oval 255.255.255
        key 255.255.255
    ]
    blanc [
        gradient 1x1 255.255.255 128.128.128
        oval 255.255.255
        key 255.255.255
    ]
    vide none
]
; ===Déclaration des styles de l'application

reversi-style: stylize [
    ; interface
    button: button gold
        font [colors: [0.0.0 255.0.0] shadow: none]
        effect []
        edge [size: 1x1 color: 0.0.0]
    choice: choice gold white
        font [colors: [0.0.0 255.0.0] shadow: none]
        effect []
        edge [size: 1x1 color: 0.0.0]
    ; jetons noirs et blancs
    jeton: box 74x74 with [
        ; 'noir, 'blanc ou 'vide
        data: 'vide
        ; coordonnées sur le plateau en cases
        coords: none
        ; listes des cases adjacentes (pour simplifier les calculs)
        gauche: droite: haut: bas: none
        haut-gauche: haut-droite: bas-gauche: bas-droite: none
        ; déclarations dans layout
        words: [
            noir [
                new/data: 'noir
                new/effect: jeton-effects/noir
                next args
            ]
            blanc [
                new/data: 'blanc
                new/effect: jeton-effects/blanc
                next args
            ]
            vide [
                new/data: 'vide
                new/effect: jeton-effects/vide
                next args
            ]
        ]
    ]
    ; clic gauche
    [
        ; si le coup est valide
        if essaie-coup face [
            ; case modifiée
            face/data: face/parent-face/joueur
            face/effect: select jeton-effects face/data
            face/parent-face/joueur: select [blanc noir blanc] face/data
            ; affichage pour le joueur suivant
            fenetre/color:
                select [blanc 255.255.255 noir 0.0.0] plateau/joueur
            show [fenetre face]
            ; pour suivre le déroulement de la partie
            coups: coups + 1
            ; plateau plein => fin
            if coups = 64 [do-face fin 'down return]
            ; si coup joué par la machine
            if plateau/joueur = ordinateur [
                ; attente avant de jouer, pour voir le coup
                wait 0.5
                use [case][
                    ; jouer le meilleur coup, sinon passer le tour
                    either case: meilleur-coup plateau/joueur [do-face case 'down][
                        do-face passer 'down
                        if not meilleur-coup plateau/joueur [do-face fin 'down]
                    ]
                ]
            ]
        ]
    ]
    ; apparence du plateau de jeu (taille: 8x8 cases + bordure)
    grille: box fond.png 602x602 with [
        joueur: 'blanc
        effect: [tile grid 75x75 0x0 34.20.14 2]
        data: array/initial [8 8] 'vide
    ]
]
; ===Fonctions d'accès aux tableaux simulés

; primitives d'accès
x-pos: func [
    "Primitive de conversion linéaire -> table."
    table [any-block!] "Série"
    width [integer!] "Largeur de la table"
][(-1 + index? table) // width + 1 ]
y-pos: func [
    "Primitive de conversion linéaire -> table."
    table [any-block!] "Série"
    width [integer!] "Largeur de la table"
][1 + to-integer (-1 + index? table) / width ]
; copies à partir d'un point

gauche: func [
  "Copie tous les éléments à gauche de la case."
  table [any-block!] "Série"
  size [pair!] "Dimensions de la table"
  /local y
][
  if 1 >= x-pos table size/x [return copy []]
  y: y-pos table size/x
  head reverse copy/part skip head table y - 1 * size/x table
]
droite: func [
  "Copie tous les éléments à droite de la case."
  table [any-block!] "Série"
  size [pair!] "Dimensions de la table"
  /local y
][
  if size/x <= x-pos table size/x [return copy []]
  y: y-pos table size/x
  copy/part next table skip head table y * size/x
]
haut: func [
  "Copie tous les éléments en haut de la case."
  table [any-block!] "Série"
  size [pair!] "Dimensions de la table"
  /local y block b-size sk
][
  if 1 >= y: y-pos table size/x [return copy []]
  block: make block! b-size: y - 1
  table: skip table sk: (- size/x)
  loop b-size [append block table/1 table: skip table sk]
  block
]
bas: func [
  "Copie tous les éléments en bas de la case."
  table [any-block!] "Série"
  size [pair!] "Dimensions de la table"
  /local y block b-size sk
][
  if size/y <= y: y-pos table size/x [return copy []]
  block: make block! b-size: size/y - y
  table: skip table sk: size/x
  loop b-size [append block table/1 table: skip table sk]
  block
]
haut-gauche: func [
  "Copie tous les éléments en haut à gauche de la case."
  table [any-block!] "Série"
  size [pair!] "Dimensions de la table"
  /local x y block b-size sk
][
  if 1 >= x: x-pos table size/x [return copy []]
  if 1 >= y: y-pos table size/x [return copy []]
  block: make block! b-size: min x - 1 y - 1
  table: skip table sk: (-1 - size/x)
  loop b-size [append block table/1 table: skip table sk]
  block
]
haut-droite: func [
  "Copie tous les éléments en haut à droite de la case."
  table [any-block!] "Série"
  size [pair!] "Dimensions de la table"
  /local x y block b-size sk
][
  if size/x <= x: x-pos table size/x [return copy []]
  if       1 >= y: y-pos table size/x [return copy []]
  block: make block! b-size: min size/x - x y - 1
  table: skip table sk: (1 - size/x)
  loop b-size [append block table/1 table: skip table sk]
  block
]
bas-gauche: func [
  "Copie tous les éléments en bas à gauche de la case."
  table [any-block!] "Série"
  size [pair!] "Dimensions de la table"
  /local x y block b-size sk
][
  if       1 >= x: x-pos table size/x [return copy []]
  if size/y <= y: y-pos table size/x [return copy []]
  block: make block! b-size: min x - 1 size/y - y
  table: skip table sk: (size/x - 1)
  loop b-size [append block table/1 table: skip table sk]
  block
]
bas-droite: func [
  "Copie tous les éléments en bas à droite de la case."
  table [any-block!] "Série"
  size [pair!] "Dimensions de la table"
  /local x y block b-size sk
][
  if size/x <= x: x-pos table size/x [return copy []]
  if size/y <= y: y-pos table size/x [return copy []]
  block: make block! b-size: min size/x - x size/y - y
  table: skip table sk: (size/x + 1)
  loop b-size [append block table/1 table: skip table sk]
  block
]
; ===Initialisations de la partie

coups-depart: func [
    "Cases autorisées en début de partie"
    /local p
][
    p: plateau/pane
    p/28/effect: p/29/effect: p/36/effect: p/37/effect: [merge tint 60]
]
; Pas de coup joué
coups: 0
; Mode 2 joueurs
ordinateur: none
; ===Déclaration et initialisation de la fenêtre

fenetre: layout [
    ; Styles prédéfinis plus haut
    styles reversi-style
    ; 'blanc commence
    backcolor white
    across
    ; Sélection de l'adversaire
    mode: choice 178
        locale mode/human-human
        locale mode/computer-white
        locale mode/computer-black
    [
        if all [
            ; si en mode 1 joueur...
            ordinateur: select reduce [1 none 2 'blanc 3 'noir]
                index? find mode/texts mode/text
            ; ...et tour de l'ordinateur
            plateau/joueur = ordinateur
        ][
            ; Coup de la machine
            use [case][
                ; attente avant de jouer, pour voir le coup
                wait 0.5
                ; jouer le meilleur coup, sinon passer le tour
                either case: meilleur-coup plateau/joueur [do-face case 'down][
                    do-face passer 'down
                    if not meilleur-coup plateau/joueur [do-face fin 'down]
                ]
            ]
        ]
    ]
    ; Sélection du niveau de difficulté en mode 1 joueur
    niveau: choice locale level/min locale level/med locale level/max
    ; Passer le tour
    passer: button locale button/skip 136 [
        plateau/joueur: select [blanc noir blanc] plateau/joueur
        fenetre/color:
            select [blanc 255.255.255 noir 0.0.0] plateau/joueur
        show fenetre
        ; Coup de la machine si en mode 1 joueur
        if plateau/joueur = ordinateur [
            use [case][
                ; attente avant de jouer, pour voir le coup
                wait 0.5
                ; jouer le meilleur coup, sinon passer le tour
                either case: meilleur-coup plateau/joueur [do-face case 'down][
                    do-face passer 'down
                    if not meilleur-coup plateau/joueur [do-face fin 'down]
                ]
            ]
        ]
    ]
    ; Terminer la partie et donner le résultat
    fin: button locale button/end 136 [
        use [total-blanc total-noir][
            ; calcul des totaux
            total-blanc: total-noir: 0
            foreach p plateau/pane [
                if p/data = 'blanc [total-blanc: total-blanc + 1]
                if p/data = 'noir   [total-noir: total-noir + 1]
            ]
            ; égalité
            either total-blanc = total-noir [
                inform layout [
                    backdrop effect [gradient 1x0 255.255.255 0.0.0]
                    banner green locale score/draw font [shadow: 1x1] feel none
                ]
            ][
                ; blanc gagnant
                either total-blanc > total-noir [
                    inform layout [
                        backcolor white
                        banner red locale score/white font [shadow: 1x1] feel none
                    ]
                ][
                    ; noir gagnant
                    inform layout [
                        backcolor black
                        banner locale score/black font [shadow: 1x1] feel none
                    ]
                ]
            ]
            ; réinitialisation du plateau et des drapeaux
            foreach p plateau/pane [p/data: 'vide p/effect: none]
            coups: 0
            plateau/joueur: 'blanc
            ordinateur: none
            mode/text: first find mode/texts locale mode/human-human
            fenetre/color: white
            ; positions de départ
            coups-depart
            show [fenetre mode] show plateau/pane
        ]
    ]
    ; aide du jeu
    aide: button "?" 20 [
        inform layout [
            backcolor rebolor
            banner locale doc/usage-title
            text as-is locale doc/usage
            text locale doc/usage-close
        ]
    ]
    return
    ; plateau de jeu
    plateau: grille with [
        ; initialisation par des cases vides
        pane: get in (layout append copy [
            styles reversi-style
            origin 1x1 space 1x1 across
        ] head insert/dup copy [] append insert/dup copy [] [jeton vide] 8 'return 8) 'pane
        init: [
            ; déclaration des références entre les cases
            use [x y p][
                x: y: 1
                p: pane
                forall p [
                    p/1/coords: to-pair reduce [x y]
                    p/1/gauche: gauche p 8x8
                    p/1/droite: droite p 8x8
                    p/1/haut: haut p 8x8
                    p/1/bas: bas p 8x8
                    p/1/haut-gauche: haut-gauche p 8x8
                    p/1/haut-droite: haut-droite p 8x8
                    p/1/bas-gauche: bas-gauche p 8x8
                    p/1/bas-droite: bas-droite p 8x8
                    x: x + 1
                    if x = 9 [x: 1 y: y + 1]
                ]
                pane: head pane
            ]
        ]
    ]
]
; ===Moteur logique du jeu

; validité d'un coup
essaie-coup: func [
    "Vérifie si un coup est valide."
    face "Case jouée"
    /local f-l c ok b
][
    ; place occupée -> faux
    if 'vide <> face/data [return false]
    ; coups d'introduction, seulement au centre
    if coups < 4 [
        use [p][
            p: face/parent-face/pane
            return either any [p/28 = face p/29 = face p/36 = face p/37 = face][true][false]
        ]
    ]
    ; cherche la présence voisine de jetons de l'adversaire suivis d'un jeton de même couleur
    ok: false
    c: face/parent-face/joueur
    foreach f-l [gauche droite haut bas haut-gauche haut-droite bas-gauche bas-droite][
        if all [face/:f-l/1 face/:f-l/1/data <> c][
            b: false
            foreach f face/:f-l [
                if any ['vide = f/data b: c = f/data][break]
            ]
            if b [ok: true foreach f face/:f-l [
                if c = f/data [break]
                f/data: c
                f/effect: select jeton-effects f/data
                show f
          ]]
        ]
    ]
    ok
]
; Table de décision du joueur machine
; tactique: 1) prendre les coins du plateau
;           2) ne pas laisser l'adversaire les prendre
;           3) contrôler les bords
;           4) retourner un maximum de jetons
valeurs: [
    [
        36
        (either ordinateur = plateau/pane/1/data [24][-18])
        5.5 5.5 5.5 5.5
        (either ordinateur = plateau/pane/8/data [24][-18])
        36
    ][
        (either ordinateur = plateau/pane/1/data [24][-18])
        (either ordinateur = plateau/pane/1/data [2][-29])
        -11 -11 -11 -11
        (either ordinateur = plateau/pane/8/data [2][-29])
        (either ordinateur = plateau/pane/8/data [24][-18])
    ][5.5 -11 1 1 1 1 -11 5.5 ][5.5 -11 1 1 1 1 -11 5.5 ][5.5 -11 1 1 1 1 -11 5.5 ][5.5 -11 1 1 1 1 -11 5.5 ][
        (either ordinateur = plateau/pane/57/data [24][-18])
        (either ordinateur = plateau/pane/57/data [2][-29])
        -11 -11 -11 -11
        (either ordinateur = plateau/pane/64/data [2][-29])
        (either ordinateur = plateau/pane/64/data [24][-18])
    ][
        36
        (either ordinateur = plateau/pane/57/data [24][-18])
        5.5 5.5 5.5 5.5
        (either ordinateur = plateau/pane/64/data [24][-18])
        36
    ]
]
; intérêt/risque actuel de prendre une case
valeur-case: func [
    "Valeur actuelle d'une case"
    offset "Position sur le plateau"
    /local x y
][
    x: offset/x y: offset/y
    do valeurs/:y/:x
]
; Détermination du meilleur coup pour le joueur actuel, à l'aide de la table de valeurs
meilleur-coup: func [
    "Recherche du meilleur coup"
    joueur "Joueur en cours"
    /local liste-coups p valeur b
][
    ; liste des coups possibles
    liste-coups: copy []
    ; en début de partie, une des case du centre
    if coups < 4 [
        p: plateau/pane
        foreach case random [28 29 36 37] [
            if 'vide = p/:case/data [return p/:case]
        ]
    ]
   
    ; construit la liste des coups possibles accompagnés de leur pondération
    foreach p plateau/pane [
        if 'vide = p/data [
            foreach f-l [
                gauche droite haut bas
                haut-gauche haut-droite bas-gauche bas-droite
            ][
                valeur: valeur-case p/coords
                if all [p/:f-l/1 p/:f-l/1/data <> joueur][
                    b: false
                    foreach f p/:f-l [
                        if any ['vide = f/data b: joueur = f/data][break]
                        valeur: valeur + valeur-case f/coords
                    ]
                    if b [repend liste-coups [valeur p]]
                ]
            ]
        ]
    ]
    ; pas de coup possible
    either empty? liste-coups [none ][
        ; tri avec les meilleurs coups en premier
        sort/reverse/skip liste-coups 2
       
        ; suivant le niveau, on prend un des 3 meilleurs/des 2 meilleurs/le meilleur
        either 6 <= length? liste-coups [
            pick liste-coups 2 * random select reduce [
                locale level/min 3 locale level/med 2 locale level/max 1
            ] first niveau/data
        ][second liste-coups ]
    ]
]
; ===Redimensionnement de la fenêtre

; référence de base
last-size: base-size: fenetre/size
; sauvegarde des dimensions et des positions de départ
base-sizes: copy []
foreach face [mode niveau passer fin aide plateau][
    face: get face
    repend base-sizes [face face/size face/offset]
    append base-sizes either face/font [face/font/size][none]
]
; sauvegarde des coordonnées des cases
jetons-offsets: copy []
foreach jeton plateau/pane [repend jetons-offsets [jeton jeton/offset]]
; adaptation de la fenêtre à l'écran actuel
fenetre/size: fenetre/size * (system/view/screen-face/size/y / 768)
; fonction de redimensionnement, lancée la 1ère fois avant l'affichage
do resize-all: insert-event-func [
    if event/type = 'resize [
        use [delta-x delta-y facteur taille][
            ;facteur de redimensionnement
            delta-x: abs fenetre/size/x - last-size/x
            delta-y: abs fenetre/size/y - last-size/y
            facteur: either delta-x > delta-y [
                fenetre/size/x / base-size/x
            ][fenetre/size/y / base-size/y ]
            if facteur < 0.014 [return event]
            ;redimensionnement des contrôles
            foreach [face size offset font] base-sizes [
                face/size: size * facteur
                face/offset: offset * facteur
                if font [face/font/size: to-integer font * facteur]
            ]
            ;redimensionnement des cases et des jetons
            taille: 74x74 * facteur
            foreach [jeton offset] jetons-offsets [
                jeton/size: taille
                jeton/offset: offset * facteur
            ]
            ;redimensionnement de la grille
            taille: 75x75 * facteur
            plateau/size: plateau/size / taille * taille + 2x2
            change find plateau/effect pair! taille
            last-size: fenetre/size
            if (abs delta-x - delta-y) > 2 [
            fenetre/size: base-size * facteur ]
            show fenetre
        ]
    ]
    event
] fenetre context [type: 'resize]
; ===Lancement du jeu

; initialisation du générateur aléatoire
random/seed now
; cases de départ
coups-depart
; affichage fenêtre principale
view/options fenetre 'resize
; ===Fin

quit

Tuesday 17 September 2013

Image resizer

The following script is a simple image resizer,it will reduce proportionally images. You can set max X or Y or both sizes.


Here is the source code:
Rebol [
Title: "Resizer"
File: %resizer.r
Author: "Massimiliano Vessi"
Date: 2011-07-22
Version: 1.1.2
email: maxint@tiscali.it
Purpose: {Simple image resizer}
]
max_L: 70
max_H: 70
suff: "_small"
ridimensiona:   does [
    immagini: request-file  
    foreach immagine_f   immagini [
        immagine_i: load-image immagine_f
        temp_imm: load-image immagine_f ;we'll use this for height check        
        if x/data [
            dimensioni: immagine_i/size
            if dimensioni/1 > max_L [
                fattore:   dimensioni/1 / max_L  
                temp_L:   layout/tight [ image (dimensioni / fattore) immagine_i ]
                temp_imm: to-image temp_L ;this will be used for heigh check
                if png/data [save/png (to-file rejoin [   immagine_f   suff_f/text ".png" ]) temp_imm]
                if bmp/data [save/bmp (to-file rejoin [   immagine_f   suff_f/text ".bmp" ]) temp_imm]
               
                ]
            ]
        if y/data [
            dimensioni: temp_imm/size ;this way, we'll use the X resized image or the original image
            if dimensioni/2 > max_H [
                fattore:   dimensioni/2 / max_H  
                temp_L:   layout/tight [ image (dimensioni / fattore) immagine_i ]
                temp_imm: to-image temp_L              
                if png/data [save/png (to-file rejoin [   immagine_f   suff_f/text ".png" ]) temp_imm]
                if bmp/data [save/bmp (to-file rejoin [   immagine_f   suff_f/text ".bmp" ]) temp_imm]
                ]
            ]
        ]
    alert "DONE!"  
    ]  
help_L: layout [
    title "Help"
    text 250 {This is software aims to create small copy of the original images, resize the to smaller size.
        You can choose what dimensions use, if software should check just length or height or both.
        You can select multiple files at one time.
        You can choose the suffix to append at the new images.
        If you need further help, you can contact me:}

    text (rejoin [ "maxint" "@" "tiscali.it" ])
    ]
view layout [
    title "THUMBNAIL GENERATOR"
    across
    x: check true
    h4 "Max Leight:"
    maxL: field (to-string max_L)
    return
    y: check
    h4 "Max Height:"
    maxL: field (to-string max_H)
    return
    h4 "Suffix:"
    suff_f: field suff ;ths suffix to append at the file names of thumbnail immages
    return
    h4 "Output image format:"
    bmp: radio
    text ".bmp"
    png: radio true
    text ".png"
    return
    button "Select image(s)" [ ridimensiona ]
    btn-help [view/new help_L ]
    ]