Thursday 29 March 2012

Unit converter

A simple unit converter, it support many units and you can choose the precision:
Here you can find the source: http://www.rebol.org/view-script.r?script=convertitore.r

Wednesday 28 March 2012

OTA bitmap to GIF converter

What is an OTA bitmap? It's a black and white image used on mobilephone, like this:
 If you have some of them and you want to convert in a more useful GIF image, you can use the following script:
REBOL [
  Title: "OTA bitmap to GIF converter"
  Date: 25-Sep-2004
  Version: 1.1
  File: %converter.r
  Author: "HY"
  Purpose: {
          Converts so-called operator logos for cell phones, i.e. OTA bitmaps
          into ordinary two-colour GIFs.
  }
  Comment: {
            This script is heavily inspired by java code. I used Adam Doppelts
            GifEncoder (cf. http://www.gurge.com/amd/old/java/GIFEncoder/index.html),
            which in turn is based upon Sverre H. Huseby's gifsave.c
            (cf. http://www.scintilla.utwente.nl/users/frank/gifsave.txt), as
            a template.
            I wrote this script in part to learn rebol. LZW compression is, I believe,
            subject to licencing (Unisys). See http://www.unisys.com/unisys/lzw/
            for details. I don't have any licence, and so if you want to use the script
            in an application, don't blame me if you get in any trouble. This code is
            revealed to the public only because someone (e.g. myself!) could learn
            something from it, NOT because I have a licence.
          }
  History: [
    1.0 [ 10-Sep-2001 "Created the script." "HY" ]
    1.1 [25-Sep-2004 "Added the script library header." "HY" ]
  ]
]
codesize: 0
compression-block: make binary! #{}
shift-left: func [value shift-count] [to-integer (value * (2 ** shift-count))]
shift-right: func [value shift-count] [to-integer (value / (2 ** shift-count))]
bit-holder: make object! [
  get-ready: func[] [
    buffer: copy array 256
    bindex: 0
    bitsleft: 8
  ]
  flush: func [/local numberofbytes] [
    numberofbytes: either bitsleft = 8 [bindex] [bindex + 1]
    if numberofbytes > zero [
      append compression-block load rejoin ["#{" pick to-hex numberofbytes 7
                                                pick to-hex numberofbytes 8
                                            "}"]
      buffer: head buffer
      loop numberofbytes [
        append compression-block first buffer
        buffer: next buffer
      ]
      change at head buffer 0 #{00}
      bindex: 0
      bitsleft: 8
    ]
  ]
  append-bits: func [bits number-of-bits /local bits-written numberofbytes] [
    bits-written: 0
    numberofbytes: 255
    while [
      ; this was a java do-block. I put the whole thing into the
      ; while-evaluation, and then nothing into the execution block.

      if ((bindex = 254) and (bitsleft = zero)) or (bindex > 254) [
        append compression-block load rejoin ["#{" pick to-hex numberofbytes 7
                                                  pick to-hex numberofbytes 8
                                              "}"]
        buffer: head buffer
        loop numberofbytes [
          append compression-block first buffer
          buffer: next buffer
        ]
        change at head buffer 0 #{00}
        bindex: 0
        bitsleft: 8
      ]
      either number-of-bits <= bitsleft [
        a: (to-integer pick head buffer (bindex + 1)) or shift-left (bits and ((shift-left 1 number-of-bits) - 1)) (8 - bitsleft)
        b: load rejoin ["#{" pick to-hex a 7 pick to-hex a 8 "}"]
        change at head buffer (bindex + 1) b
        bits-written: bits-written + number-of-bits
        bitsleft: bitsleft - number-of-bits
        number-of-bits: 0
      ] [
        a: (to-integer pick head buffer (bindex + 1)) or shift-left (bits and ((shift-left 1 bitsleft) - 1)) (8 - bitsleft)
        b: load rejoin ["#{" pick to-hex a 7 pick to-hex a 8 "}"]
        change at head buffer (bindex + 1) b
        bits-written: bits-written + bitsleft
        bits: shift-right bits bitsleft
        number-of-bits: number-of-bits - bitsleft
        bindex: bindex + 1
        change at head buffer (bindex + 1) #{00}
        bitsleft: 8
      ]
      number-of-bits <> zero
    ] [comment { empty while execution block } ]
  ]
]
  LZW-stringtable: make object! [
    res-codes: 2
    hash-free: -1
    next-first: -1
    maxbits: 12
    maxstr: shift-left 1 maxbits
    hashsize: 9973
    hashstep: 2039
    num-strings: 0
    get-ready: func[] [
      str-chr: copy array maxstr
      str-nxt: copy array maxstr
      str-hsh: copy array hashsize
    ]
    clear-table: func [codesize /local w] [
      num-strings: 0
      str-hsh: copy array/initial hashsize hash-free
      w: (shift-left 1 codesize) + res-codes
      repeat current w [
        add-char-string -1 (current - 1)
      ]
    ] ; end clear-table

    add-char-string: func [aindex byte /local hashindex hash-plus-one] [
      if num-strings >= maxstr [ return -1 ]
      hashindex: hash-it aindex byte
      hash-plus-one: hashindex + 1
      while [str-hsh/:hash-plus-one <> hash-free] [hashindex: remainder (hashindex + hashstep) hashsize ]
      change at str-hsh (hashindex + 1) num-strings
      change at str-chr (num-strings + 1) byte
      change at str-nxt (num-strings + 1) either aindex = hash-free [next-first] [aindex]
      num-strings: num-strings + 1
      return num-strings
    ] ; end add-char-string

    find-char-string: func [findex byte /local hashindex nextindex] [
      if findex = hash-free [ return byte ]
      hashindex: hash-it findex byte
      while [nextindex: to-integer pick head str-hsh (hashindex + 1)
              hash-free <> nextindex ]
            [
        if ((to-integer (pick head str-nxt (nextindex + 1))) = findex) and
          ((to-integer (pick head str-chr (nextindex + 1))) = byte) [
            return nextindex ]
        hashindex: remainder (hashindex + hashstep) hashsize
      ]
      return -1
    ]
    hash-it: func [hindex lastbyte] [return remainder (((shift-left lastbyte 8) xor hindex) and to-integer #{FFFF}) hashsize ] ; end hash-it

] ; end LZW-stringtable

bits-needed: func [n [integer!] ] [
  ret: 1
  if n - 1 = zero [ return zero ]
  while [(n: to-integer n / 2) <> zero] [ret: ret + 1 ]
  ret
]
LZW-compress: func [tobecompressed [string!] the-size [integer!] /local index] [
  prefix: -1
  holder: make bit-holder []
  holder/get-ready
  stringtable: make LZW-stringtable []
  stringtable/get-ready
  clearcode: shift-left 1 the-size
  endofinfo: clearcode + 1
  numberofbits: the-size + 1
  limit: (shift-left 1 numberofbits) - 1
  stringtable/clear-table the-size
  holder/append-bits clearcode numberofbits
  foreach c tobecompressed [
    index: stringtable/find-char-string prefix to-integer to-string c
    either index = -1 [
      holder/append-bits prefix numberofbits
      gg: (stringtable/add-char-string prefix to-integer to-string c) - 1
      if gg > limit [
        numberofbits: numberofbits + 1
        if numberofbits > 12 [
          holder/append-bits clearcode (numberofbits - 1)
          stringtable/clear-table
          numberofbits: codesize + 1
        ]
        limit: (shift-left 1 numberofbits) - 1
      ]
      prefix: (to-integer to-string c) and (to-integer #{FF})
    ][prefix: index ]
  ]
  if prefix <> -1 [holder/append-bits to-integer prefix numberofbits ]
  holder/append-bits endofinfo numberofbits
  holder/flush
  compression-block
]
imagedescriptor: func [separator [char!] w [integer!] h [integer!]] [
  descriptor: make block! 10
  append descriptor to-binary separator
  infobyte: 0
  infobyte: infobyte or 0   ; The rightmost bit: Local Color Table (OFF)
  infobyte: infobyte or 0   ; Interlace flag (next bit) (OFF)
  infobyte: infobyte or 0   ; Sort flag (1 bit) (not sorted)
  infobyte: infobyte or 24 ; Two reserved bits - OFF or ON -- no difference
  infobyte: infobyte or 7   ; Size of Local Colour Table (3 last bits)
                          ; (No local colour table, so this may be whatever pleases the most)

  ; simply setting left and top offsets to zero:
  append descriptor #{0000}
  append descriptor #{0000} ; two bytes for each offset value

  ; width and height parameters:
  append descriptor load rejoin ["#{" pick to-hex w 7
                                      pick to-hex w 8
                                      pick to-hex w 5
                                      pick to-hex w 6
                                "}"]
  append descriptor load rejoin ["#{" pick to-hex h 7
                                      pick to-hex h 8
                                      pick to-hex h 5
                                      pick to-hex h 6
                                "}"]
  append descriptor load rejoin ["#{"   pick to-hex infobyte 7
                                      pick to-hex infobyte 8
                                "}"]
  descriptor
]
graphiccontrolextension: func [] [
  extension: make block! 7
  infobyte: 0 ; this infobyte contains lots of unimportant, unspecified information
  infobyte: infobyte or 0 ; The rightmost bit: Transparent Colour Flag.

  ; First, two bytes with fixed values:
  append extension #{21} ; Extension introducer
  append extension #{F9} ; Graphic Control Label

  append extension #{04} ; Block Size - fixed value, according to the GIF89 spec

  append extension load rejoin ["#{" pick to-hex infobyte 7
                                    pick to-hex infobyte 8
                                "}"]
  append extension #{00} ; Delay Time (we don't use animation)
  append extension #{00} ; Delay Time (we don't use animation) (two bytes, unsigned)

  append extension #{00} ; Transparency index (if   not transparent, this will be the Block Terminator instead)

  rejoin extension
]
screendescriptor: func [] [
  descriptor: make block! 7
  infobyte: 0
  infobyte: infobyte or 128 ; Global Colour Table flag (first bit)
  infobyte: infobyte or 112 ; Colour resolution (next 3 bits)
  infobyte: infobyte or zero ; Sort flag (fifth bit; set to 0, since our Global Colour Table is _not_ sorted)
  infobyte: infobyte or ((bits-needed(2) - 1) and 7) ; Global Colour Table size (last 3 bits)

  append descriptor load rejoin ["#{" pick to-hex width 7
                                      pick to-hex width 8
                                      pick to-hex width 5
                                      pick to-hex width 6
                                "}"]
  append descriptor load rejoin ["#{" pick to-hex height 7
                                      pick to-hex height 8
                                      pick to-hex height 5
                                      pick to-hex height 6
                                "}"]
  append descriptor load rejoin ["#{"   pick to-hex infobyte 7
                                      pick to-hex infobyte 8
                                "}"]
  append descriptor load rejoin ["#{"   skip tail reverse to-hex zero -2 "}"] ; index of background colour in colour table

  append descriptor load rejoin ["#{"   skip tail reverse to-hex zero -2 "}"] ; i.e. no pixel aspect ratio information is given

  comment {
    Something is very wrong here, but I use this script for OTA bitmap conversion only,
    and it works for that purpose. I recommend anyone who want to use this script for
    any other purpose to completely rewrite the screendescriptor method!
  }

  rejoin descriptor
]
convert: func [bitmap /local gif ] [
  if not (length? bitmap) = 260 [
    print "Wrong length of argument."
    ;return
  ]
  gif-header: to-binary "GIF89a"
  gif: gif-header
  if (first bitmap) <> #"0" [print "First character is non-null!" ]
  if (second bitmap) <> #"0" [print "Second character is non-null!" ] ; both of which are wrong, in OTAs...
  bitmap: skip bitmap 2
  ; first the width parameter as hex,
  width: to-integer to-issue append to-string first bitmap second bitmap
  bitmap: skip bitmap 2
  ; then the height,
  height: to-integer to-issue append to-string first bitmap second bitmap
  bitmap: skip bitmap 2
  ; and finally the number of colours. This number should be 1, in OTAs:
  colours: to-integer to-issue append to-string first bitmap second bitmap
  bitmap: skip bitmap 2
  if colours > 1 [print "Bitmap claims to have more than two colours!" ]
  raster: make block! width * height
  loop (width * height) / 4 [
    append raster to-string skip (to-string enbase/base load rejoin ["#{0" first bitmap "}"] 2) 4
    bitmap: next bitmap
  ]
  if (length? bitmap) > 0 [print "There seems to be unread bytes left in the input bitmap!" ]
  append gif #{48000E00F00000} ; should be: append gif screendescriptor

  ; I could have made a sub-routine to set the colour table,
  ; but since I know this is a two-colour gif, I'll simply add
  ; it statically, like this:
  append gif #{FFFFFF000000}
  append gif #{21F90400000000} ; should be: append gif graphiccontrolextension

  append gif #{00} ; Block Terminator for Graphic Control Extension

  append gif #{2C0000000048000E001F} ; should be: append gif imagedescriptor #"," width height

  codesize: bits-needed(2) ; LZW Minimum Code Size (for two colours)
  if codesize = 1 [codesize: 2 ]
  append gif load rejoin ["#{" pick to-hex codesize 7
                              pick to-hex codesize 8
                          "}"]
  append gif LZW-compress to-string raster codesize
  append gif #{00}
  append gif #{3B00000000000000001F} ; should be: append gif imagedescriptor #";" 0 0

  append gif to-binary "!þImage generated with REBOL"
  append gif #{00} ; closes the comment block

  gif
]
get-bitmap: func [query /local bitmap] [
  bitmap: find query "bitmap="
  if not none? bitmap [ bitmap: skip bitmap 7 ]
  to-string bitmap
]


Here an example, it's all in only one line:

write %converted.gif convert "00480E0118000000F80FC007F818003803FC0FF007F818006F03BC0EF807F018007F83000E3C07F00800C382001C1403E01800C1C2001C1C03E01800C0C2000C1C01E01801C0C6000E1C01C01801C1C61F063800C01801C1821F03F800801800E3820101F0000019C0FF0387000000001FE03E01FF000001C01FC00000FB000001C0"

Here the result:
You can find more about OTA bitmap here: http://en.wikipedia.org/wiki/OTA_bitmap

Monday 26 March 2012

CSV importation

CSV is a very common way to write a table of data. It's very easy to import it using parse, here a simple function:

csv-import: func [
    "Import a CSV file transforming it in a series."
    file [file!] "CSV file"
    /local temp temp2
    ] [
    temp: read/lines file
    temp2: copy []
    foreach item temp [append/only temp2 (parse/all item ",") ]
    return temp2    
    ]
   


And here an example, the following table:
TITLE AUTHOR Editor
Robots and Empire Isaac Asimov Mondadori
Afternoon of Earth Brian W. Aldiss Minotauro
Absolute OpenBSD "2d Edition" Michael W. Lucas No Starch Press
The space merchants Frederik Pohl, C. M. Kornbluth Mondadori

It can be represented in CSV format this way:

TITLE,AUTHOR,EDITOR
Robots and Empire,Isaac Asimov,Mondadori
Afternoon of Earth,Brian W. Aldiss,Minotauro
"Absolute OpenBSD ""2d Edition""",Michael W. Lucas,No Starch Press
The space merchants,"Frederik Pohl, C. M. Kornbluth",Mondadori


Writing it on temp.csv file and using the above functions:

>> a: csv-import %temp.csv
== [["TITLE" "AUTHOR" "EDITOR"] ["Robots and Empire" "Isaac Asimov" "Mondadori"] ["Afternoon of Earth" "Brian W. Aldiss" "Minotauro...

So it's extremely easy to retrieve data:

>> a/1/1
== "TITLE"
>> a/1/2
== "AUTHOR"
>> a/2/1
== "Robots and Empire"

Or this way:

>> for i 1 5 1 [print a/:i/1]
TITLE
Robots and Empire
Afternoon of Earth
Absolute OpenBSD
The space merchants

Friday 23 March 2012

Funny console

If you need to retrieve what happened on your console, you can read system/console/history:

>> print "Hello world"
Hello world
>> print system/console/history
print system/console/history print "Hello world"


You can modify your console, just look a this:

>> print system/console
history: ["print system/console" "print system/console/history" {print "Hello world"}]
keys: none
prompt: ">> "
result: "== "
escape: "(escape)"
busy: "|/-\"
tab-size: 4
break: true
lookup: func [
"Console filename completion lookup."
file /value
][
if #"/" <> last file [file: first split-path file]
attempt [read file]
]

You can change the prompt symbol, the result symbol, the busy simbols, the tab size and lot more, try this:

system/console/prompt: "At your order, Master> "

Thursday 22 March 2012

Parse rules

Parse is the Rebol command to split a text or manipulate a text following your rules. (see http://www.rebol.com/docs/core23/rebolcore-15.html)
The following codes may help you to write your rules:

Octet: charset [#"^(00)" - #"^(FF)"]

This is very powerful, it means all chars from UTF-8 "0" code to UTF-8 "FF" code. Here the codes that it represents, the last 20 are special UTF-8 chars:
[ ]  U+0020        SPACE
[!]  U+0021        EXCLAMATION MARK
["]  U+0022        QUOTATION MARK
[#]  U+0023        NUMBER SIGN
[$]  U+0024        DOLLAR SIGN
[%]  U+0025        PERCENT SIGN
[&]  U+0026        AMPERSAND
[']  U+0027        APOSTROPHE
[(]  U+0028        LEFT PARENTHESIS
[)]  U+0029        RIGHT PARENTHESIS
[*]  U+002A        ASTERISK
[+]  U+002B        PLUS SIGN
[,]  U+002C        COMMA
[-]  U+002D        HYPHEN-MINUS
[.]  U+002E        FULL STOP
[/]  U+002F        SOLIDUS
[0]  U+0030        DIGIT ZERO
[1]  U+0031        DIGIT ONE
[2]  U+0032        DIGIT TWO
[3]  U+0033        DIGIT THREE
[4]  U+0034        DIGIT FOUR
[5]  U+0035        DIGIT FIVE
[6]  U+0036        DIGIT SIX
[7]  U+0037        DIGIT SEVEN
[8]  U+0038        DIGIT EIGHT
[9]  U+0039        DIGIT NINE
[:]  U+003A        COLON
[;]  U+003B        SEMICOLON
[<]  U+003C        LESS-THAN SIGN
[=]  U+003D        EQUALS SIGN
[>]  U+003E        GREATER-THAN SIGN
[?]  U+003F        QUESTION MARK
[@]  U+0040        COMMERCIAL AT
[A]  U+0041        LATIN CAPITAL LETTER A
[B]  U+0042        LATIN CAPITAL LETTER B
[C]  U+0043        LATIN CAPITAL LETTER C
[D]  U+0044        LATIN CAPITAL LETTER D
[E]  U+0045        LATIN CAPITAL LETTER E
[F]  U+0046        LATIN CAPITAL LETTER F
[G]  U+0047        LATIN CAPITAL LETTER G
[H]  U+0048        LATIN CAPITAL LETTER H
[I]  U+0049        LATIN CAPITAL LETTER I
[J]  U+004A        LATIN CAPITAL LETTER J
[K]  U+004B        LATIN CAPITAL LETTER K
[L]  U+004C        LATIN CAPITAL LETTER L
[M]  U+004D        LATIN CAPITAL LETTER M
[N]  U+004E        LATIN CAPITAL LETTER N
[O]  U+004F        LATIN CAPITAL LETTER O
[P]  U+0050        LATIN CAPITAL LETTER P
[Q]  U+0051        LATIN CAPITAL LETTER Q
[R]  U+0052        LATIN CAPITAL LETTER R
[S]  U+0053        LATIN CAPITAL LETTER S
[T]  U+0054        LATIN CAPITAL LETTER T
[U]  U+0055        LATIN CAPITAL LETTER U
[V]  U+0056        LATIN CAPITAL LETTER V
[W]  U+0057        LATIN CAPITAL LETTER W
[X]  U+0058        LATIN CAPITAL LETTER X
[Y]  U+0059        LATIN CAPITAL LETTER Y
[Z]  U+005A        LATIN CAPITAL LETTER Z
[[]  U+005B        LEFT SQUARE BRACKET
[\]  U+005C        REVERSE SOLIDUS
[]]  U+005D        RIGHT SQUARE BRACKET
[^]  U+005E        CIRCUMFLEX ACCENT
[_]  U+005F        LOW LINE
[`]  U+0060        GRAVE ACCENT
[a]  U+0061        LATIN SMALL LETTER A
[b]  U+0062        LATIN SMALL LETTER B
[c]  U+0063        LATIN SMALL LETTER C
[d]  U+0064       LATIN SMALL LETTER D
[e]  U+0065       LATIN SMALL LETTER E
[f]  U+0066       LATIN SMALL LETTER F
[g]  U+0067       LATIN SMALL LETTER G
[h]  U+0068       LATIN SMALL LETTER H
[i]  U+0069       LATIN SMALL LETTER I
[j]  U+006A       LATIN SMALL LETTER J
[k]  U+006B       LATIN SMALL LETTER K
[l]  U+006C       LATIN SMALL LETTER L
[m]  U+006D       LATIN SMALL LETTER M
[n]  U+006E       LATIN SMALL LETTER N
[o]  U+006F       LATIN SMALL LETTER O
[p]  U+0070       LATIN SMALL LETTER P
[q]  U+0071       LATIN SMALL LETTER Q
[r]  U+0072       LATIN SMALL LETTER R
[s]  U+0073       LATIN SMALL LETTER S
[t]  U+0074       LATIN SMALL LETTER T
[u]  U+0075       LATIN SMALL LETTER U
[v]  U+0076       LATIN SMALL LETTER V
[w]  U+0077       LATIN SMALL LETTER W
[x]  U+0078       LATIN SMALL LETTER X
[y]  U+0079       LATIN SMALL LETTER Y
[z]  U+007A       LATIN SMALL LETTER Z
[{]  U+007B       LEFT CURLY BRACKET
[|]  U+007C       VERTICAL LINE
[}]  U+007D       RIGHT CURLY BRACKET
[~]  U+007E       TILDE
[ ]  U+00A0       NO-BREAK SPACE
[¡]  U+00A1       INVERTED EXCLAMATION MARK
[¢]  U+00A2       CENT SIGN
[£]  U+00A3       POUND SIGN
[¤]  U+00A4       CURRENCY SIGN
[¥]  U+00A5       YEN SIGN
[¦]  U+00A6       BROKEN BAR
[§]  U+00A7       SECTION SIGN
[¨]  U+00A8       DIAERESIS
[©]  U+00A9       COPYRIGHT SIGN
[ª]  U+00AA       FEMININE ORDINAL INDICATOR
[«]  U+00AB       LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
[¬]  U+00AC       NOT SIGN
[ ]  U+00AD       SOFT HYPHEN
[®]  U+00AE       REGISTERED SIGN
[¯]  U+00AF       MACRON
[°]  U+00B0       DEGREE SIGN
[±]  U+00B1       PLUS-MINUS SIGN
[²]  U+00B2       SUPERSCRIPT TWO
[³]  U+00B3       SUPERSCRIPT THREE
[´]  U+00B4       ACUTE ACCENT
[µ]  U+00B5       MICRO SIGN
[¶]  U+00B6       PILCROW SIGN
[·]  U+00B7       MIDDLE DOT
[¸]  U+00B8       CEDILLA
[¹]  U+00B9       SUPERSCRIPT ONE
[º]  U+00BA       MASCULINE ORDINAL INDICATOR
[»]  U+00BB       RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
[¼]  U+00BC       VULGAR FRACTION ONE QUARTER
[½]  U+00BD       VULGAR FRACTION ONE HALF
[¾]  U+00BE       VULGAR FRACTION THREE QUARTERS
[¿]  U+00BF       INVERTED QUESTION MARK
[À]  U+00C0       LATIN CAPITAL LETTER A WITH GRAVE
[Á]  U+00C1       LATIN CAPITAL LETTER A WITH ACUTE
[Â]  U+00C2       LATIN CAPITAL LETTER A WITH CIRCUMFLEX
[Ã]  U+00C3       LATIN CAPITAL LETTER A WITH TILDE
[Ä]  U+00C4       LATIN CAPITAL LETTER A WITH DIAERESIS
[Å]  U+00C5       LATIN CAPITAL LETTER A WITH RING ABOVE
[Æ]  U+00C6       LATIN CAPITAL LETTER AE
[Ç]  U+00C7       LATIN CAPITAL LETTER C WITH CEDILLA
[È]  U+00C8       LATIN CAPITAL LETTER E WITH GRAVE
[É]  U+00C9       LATIN CAPITAL LETTER E WITH ACUTE
[Ê]  U+00CA       LATIN CAPITAL LETTER E WITH CIRCUMFLEX
[Ë]  U+00CB       LATIN CAPITAL LETTER E WITH DIAERESIS
[Ì]  U+00CC       LATIN CAPITAL LETTER I WITH GRAVE
[Í]  U+00CD       LATIN CAPITAL LETTER I WITH ACUTE
[Î]  U+00CE       LATIN CAPITAL LETTER I WITH CIRCUMFLEX
[Ï]  U+00CF       LATIN CAPITAL LETTER I WITH DIAERESIS
[Ð]  U+00D0       LATIN CAPITAL LETTER ETH
[Ñ]  U+00D1       LATIN CAPITAL LETTER N WITH TILDE
[Ò]  U+00D2       LATIN CAPITAL LETTER O WITH GRAVE
[Ó]  U+00D3       LATIN CAPITAL LETTER O WITH ACUTE
[Ô]  U+00D4       LATIN CAPITAL LETTER O WITH CIRCUMFLEX
[Õ]  U+00D5       LATIN CAPITAL LETTER O WITH TILDE
[Ö]  U+00D6       LATIN CAPITAL LETTER O WITH DIAERESIS
[×]  U+00D7       MULTIPLICATION SIGN
[Ø]  U+00D8       LATIN CAPITAL LETTER O WITH STROKE
[Ù]  U+00D9       LATIN CAPITAL LETTER U WITH GRAVE
[Ú]  U+00DA       LATIN CAPITAL LETTER U WITH ACUTE
[Û]  U+00DB       LATIN CAPITAL LETTER U WITH CIRCUMFLEX
[Ü]  U+00DC       LATIN CAPITAL LETTER U WITH DIAERESIS
[Ý]  U+00DD       LATIN CAPITAL LETTER Y WITH ACUTE
[Þ]  U+00DE       LATIN CAPITAL LETTER THORN
[ß]  U+00DF       LATIN SMALL LETTER SHARP S
[à]  U+00E0       LATIN SMALL LETTER A WITH GRAVE
[á]  U+00E1       LATIN SMALL LETTER A WITH ACUTE
[â]  U+00E2       LATIN SMALL LETTER A WITH CIRCUMFLEX
[ã]  U+00E3       LATIN SMALL LETTER A WITH TILDE
[ä]  U+00E4       LATIN SMALL LETTER A WITH DIAERESIS
[å]  U+00E5       LATIN SMALL LETTER A WITH RING ABOVE
[æ]  U+00E6       LATIN SMALL LETTER AE
[ç]  U+00E7       LATIN SMALL LETTER C WITH CEDILLA
[è]  U+00E8       LATIN SMALL LETTER E WITH GRAVE
[é]  U+00E9       LATIN SMALL LETTER E WITH ACUTE
[ê]  U+00EA       LATIN SMALL LETTER E WITH CIRCUMFLEX
[ë]  U+00EB       LATIN SMALL LETTER E WITH DIAERESIS
[ì]  U+00EC       LATIN SMALL LETTER I WITH GRAVE
[í]  U+00ED       LATIN SMALL LETTER I WITH ACUTE
[î]  U+00EE       LATIN SMALL LETTER I WITH CIRCUMFLEX
[ï]  U+00EF       LATIN SMALL LETTER I WITH DIAERESIS
[ð]  U+00F0       LATIN SMALL LETTER ETH
[ñ]  U+00F1       LATIN SMALL LETTER N WITH TILDE
[ò]  U+00F2       LATIN SMALL LETTER O WITH GRAVE
[ó]  U+00F3       LATIN SMALL LETTER O WITH ACUTE
[ô]  U+00F4       LATIN SMALL LETTER O WITH CIRCUMFLEX
[õ]  U+00F5       LATIN SMALL LETTER O WITH TILDE
[ö]  U+00F6       LATIN SMALL LETTER O WITH DIAERESIS
[÷]  U+00F7       DIVISION SIGN
[ø]  U+00F8       LATIN SMALL LETTER O WITH STROKE
[ù]  U+00F9       LATIN SMALL LETTER U WITH GRAVE
[ú]  U+00FA       LATIN SMALL LETTER U WITH ACUTE
[û]  U+00FB       LATIN SMALL LETTER U WITH CIRCUMFLEX
[ü]  U+00FC       LATIN SMALL LETTER U WITH DIAERESIS
[ý]  U+00FD       LATIN SMALL LETTER Y WITH ACUTE
[þ]  U+00FE       LATIN SMALL LETTER THORN
U+0000  NULL 
U+0001  START OF HEADING 
U+0002  START OF TEXT 
U+0003  END OF TEXT 
U+0004  END OF TRANSMISSION 
U+0005  ENQUIRY 
U+0006  ACKNOWLEDGE 
U+0007  BELL 
U+0008  BACKSPACE 
U+0009 Cc;0;S ;N;CHARACTER TABULATION 
U+000A Cc;0;B ;N;LINE FEED (LF) 
U+000B Cc;0;S ;N;LINE TABULATION 
U+000C Cc;0;WS ;N;FORM FEED (FF) 
U+000D Cc;0;B ;N;CARRIAGE RETURN (CR) 
U+000E  SHIFT OUT 
U+000F  SHIFT IN 
U+0010  DATA LINK ESCAPE 
U+0011  DEVICE CONTROL ONE 
U+0012  DEVICE CONTROL TWO 
U+0013  DEVICE CONTROL THREE 
U+0014  DEVICE CONTROL FOUR 
U+0015  NEGATIVE ACKNOWLEDGE 
U+0016  SYNCHRONOUS IDLE 
U+0017  END OF TRANSMISSION BLOCK 
U+0018  CANCEL 
U+0019  END OF MEDIUM 
U+001A  SUBSTITUTE 
U+001B  ESCAPE 
U+001C INFORMATION SEPARATOR FOUR 
U+001D INFORMATION SEPARATOR THREE 
U+001E INFORMATION SEPARATOR TWO 
U+001F INFORMATION SEPARATOR ONE 
The following represents all chars (uppercase and lowercase):

Char: charset [#"^(00)" - #"^(7F)"]

The following all digits:

Digit: charset "0123456789"

The following check if there some number combination:

>> Digits: [some Digit]
== [some Digit]
>> parse "552" digits
== true

Uppercase chars:

Upper: charset [#"A" - #"Z"]

Lowercase chars:

Lower: charset [#"a" - #"z"]

Another way to make all chars:

Alpha: union Upper Lower

All chars and digits:

>> AlphaDigit: union Alpha Digit
>> parse "Hello 123" [some alphadigit]
== true

Control chars:

Control: charset [#"^(00)" - #"^(1F)" #"^(7F)"]

Hexadecimal values:

>> Hex: union Digit charset [#"A" - #"F" #"a" - #"f"]
>> parse "1a2" [some hex]
== true

The TAB:

>> tab
== #"^-"
>> HT: #"^-"

Linear white space (LWS), a combination of space and tab:

>> SP: #" "
>> LWS: charset reduce [SP HT]

New line and carriage return, white spaces:

>> newline
== #"^/"
>> LF
== #"^/"
>> cr
== #"^M"
>> WS: charset reduce [SP HT newline CR LF]

Punctuation:

Graphic: charset [#"^(21)" - #"^(7E)"]

Monday 19 March 2012

Color names

Writing a graphical interface, Rebol permit you to write the color using a RGB tuple, like 0.0.0, or with the color name, like black.
Here a couple of example:

view layout [ button black "Click me" ]

or

view layout [ button 0.0.0 "Click me"]

Here the result:
 However there are a loot of colors memorized as a name in Rebol, here a script that help you to remember all:
Here the source:
REBOL [
    Title: "REBOL Standard Colors"
    Date: 31-Mar-2001
    Version: 1.0.2
    File: %color-names.r
    Author: ["Carl Sassenrath" "Massimiliano Vessi"]
    Purpose: "Displays the official built-in REBOL named colors."
    Email: carl@rebol.com
]
colors:   [
    black   blue     navy   orange gold     tan
    coal   green   leaf   forest brown   coffee
    gray   cyan     teal   aqua   water   sky
    pewter red     maroon brick   crimson pink
    silver magenta purple violet papaya   rebolor
    snow   yellow   olive   oldrab khaki   mint
    white   ivory   linen   beige base-color
    reblue sienna wheat
]
sort colors
out: [
    style btn button font-size 11 100x38 [
    sc/color: face/color
    sc/text: reform ["Click a color to show it here ^/" face/text]
    show sc
    ]
    across
]
cnt: 1
foreach color colors [
    repend out ['btn color reform [color newline get color]]
    if zero? cnt // 6 [append out 'return]
    cnt: cnt + 1
]
append out [
    sl: slider 208x38 "Multiplier" font [
        color: silver align: 'center valign: 'middle shadow: none][mult-color value ]
    return
    sc: box 650x80 font-size 12 "Click a color to show it here" return
    button 650x40 black "Click here for custom color" [
        face/color: request-color/color any [face/color gray]
        face/texts: reduce [reform   face/color ]
        show face
    ]
]
mult-color: func [factor /local clr n m d] [
    n: 1
    m: max 1 to-integer factor - .5 * 8
    d: max 1 to-integer .5 - factor * 8
    sl/text: reform either factor > .5 [["times" m]][["divided by" d]]
    foreach color colors [
        clr: either factor > .5 [(get color) * m][(get color) / d]
        window/pane/:n/color: clr
        window/pane/:n/texts: reduce [reform [color newline clr]]
        n: n + 1
    ]
    show window
]
window: layout out
view window


The REBOL predefined color words, that you can use everywhere (VID, DRAW, script), are:


NameValueColor  NameValueColor
aqua40.100.130 base-color200.200.200 
beige255.228.196 black0.0.0 
blue0.0.255 brick178.34.34 
brown139.69.19 coal64.64.64 
coffee76.26.0 crimson220.20.60 
cyan0.255.255 forest0.48.0 
gold255.205.40 gray128.128.128 
green0.255.0 ivory255.255.240 
khaki179.179.126 leaf0.128.0 
linen250.240.230 magenta255.0.255 
maroon128.0.0 mint100.136.116 
navy0.0.128 oldrab72.72.16 
olive128.128.0 orange255.150.10 
papaya255.80.37 pewter170.170.170 
pink255.164.200 purple128.0.128 
reblue38.58.108 rebolor142.128.110 
red255.0.0 sienna160.82.45 
silver192.192.192 sky164.200.255 
snow240.240.240 tan222.184.135 
teal0.128.128 violet72.0.90 
water80.108.142 wheat245.222.129 
white255.255.255 yellow255.255.0 

Wednesday 14 March 2012

Color match game

This is the equivalent of an old Amiga game. Your task is to find the correct mix of primary colors in order to obtain the requested color. Push on TEST button to see if you are correct.
 Here the source:

REBOL [
    Title:   "Colormatch 1.5"
    File:   %colormatch15.r
    Author: "Scot M. Sutherland"
    Verson: 1.5.1
    Date: 15-Mar-2007
    Copyright: "©2006, by Scot M. Sutherland.   All rights reserved."
    Purpose: {Color Match 1.5 simulates very closely the Amiga Version created in 1987.
Junior High students learned how to created accurate colors by typing in numbers into a
multimedia program.
}
    Notes: {
        12-Oct-2006 Rewrite of colormatch for 64 colors, and bigger handles.
                    Leaping slider handles added.
    }
]
col-nos: 4
col-fact: 256 / col-nos
random/seed now
s: 10
rand-color: func [/local col v vf] [
    col: copy [] v: 0
    loop 3 [
        v: ((random (col-nos + 1)) - 1)
        either v > 0 [vf: (v * col-fact) - 1][vf: 0]
        append col vf
    ]
    return to-tuple col
]
rank?: func [score /local rank] [
    rank: "Drop Out!"
    if (score > 5) [rank: "Nerd"]
    if (score > 6) [rank: "Geek"]
    if (score > 7) [rank: "Expert"]
    if (score > 8) [rank: "ACE!"]
    return rank
]
s-off: func [c sv z /local color [tuple!] off [pair!] val [integer!] data y sy ][
    y: (to-integer (second parse mold z "x")) - 18
    if sv < 1 [sy: y - 4 off: to-pair reduce [0 sy] color: c * 0 val: 0 data: 1]
    if sv < .95 [sy: y * .75 off: to-pair reduce [0 sy] color: c * .25 val: 1 data: .75]
    if sv < .625 [sy: y * .5 off: to-pair reduce [0 sy] color: c * .5 val: 2   data: .5]
    if sv < .375 [sy: y * .25 off: to-pair reduce [0 sy] color: c * .75 val: 3 data: .25]
    if sv < .05 [off: 0x0 color: c val: 4 data: 0.0]
    return reduce [color off val data]
]
;for x 0 16 1 [probe (x * 16)]

lay: layout [
    style t-box box 150x100
    backdrop forest + 100 effect [gradient 1x1 20.200.80 30.90.50]
    vh1 150 center Gold "Colormatch 1.5"
        feel [over: func [f a o] [
            prompt/text: either a ["Intuica, Inc. Patent Pending"] ["Move sliders...Click Test."] show prompt]
        ]
    prompt: txt white 155 center "Move sliders...Click Test" space 0x0
    frame: box 156x206 edge [size: 3x3 color: gray effect: 'bevel]
    at frame/offset + 3x3
    targ: t-box rand-color "Target"
        feel [over: func [f a o] [
            prompt/text: either a ["Start over..."] ["Move sliders...Click Test."] show prompt]
        ][
            targ/color: rand-color targ/color
            test/text: "Test" targ/text: "Target"
            score/text: "10" s: 10
            test/color: r/data: g/data: b/data: 1.0
            r/color: g/color: b/color: 0
            rt/text: gt/text: bt/text: "0"
            show [targ test r g b rt gt bt score]
    ]
    test: t-box 150x100 black "Test"
            feel [over: func [f a o] [
            prompt/text: either a ["Test for a match..."] ["Move sliders...Click Test."] show prompt]
        ][
        score/text: s: s - 1
        test/color: r/color + g/color + b/color
        if test/color = targ/color [rank/text: rank? s test/text: "MATCH!"   targ/text: "New Color"]
        show [test score rank targ]
    ]
    across space (frame/size / 10) * 1x0
    guide (frame/offset + (frame/size * 0x1) + 15x15)
    rt: vh4 30 "0"   gt: vh4 30 "0" bt: vh4 30 "0" return pad 3x5
    space ((frame/size / 5) - 5 ) * 1x0
    r: slider 20x192
            feel [over: func [f a o] [
            prompt/text: either a ["Red slider..."] ["Move sliders...Click Test."] show prompt]
        ][
        rv: s-off red r/data r/size
        if find rv none [rv: reduce [black   (r/size * 0x1 - (r/pane/1/size * 0x1) - 0x4) 0 1.0]]
        r/pane/1/offset: second rv
        r/data: fourth rv
        rt/text: third rv
        r/color: first rv
        show [r rt]
    ]
    g: slider 20x192
            feel [over: func [f a o] [
            prompt/text: either a ["Green slider..."] ["Move sliders...Click Test."] show prompt]
        ][
        gv: s-off green g/data g/size
        if find gv none [gv: reduce [black   (g/size * 0x1 - (g/pane/1/size * 0x1) - 0x4) 0 1.0]]
        g/pane/1/offset: second gv
        g/data: fourth gv
        gt/text: third gv
        g/color: first gv
        show [g gt]
    ]
    b: slider 20x192
            feel [over: func [f a o] [
            prompt/text: either a ["Blue slider..."] ["Move sliders...Click Test."] show prompt]
        ][
        bv: s-off blue b/data b/size
        if find bv none [bv: reduce [black   (b/size * 0x1 - (b/pane/1/size * 0x1) - 0x4) 0 1.0]]
        b/pane/1/offset: second bv
        b/data: fourth bv
        bt/text: third bv
        b/color: first bv
        show [b bt]
    ]
    return space 5x5 pad 0x20
    vh4 gold "Score: " score: vh4 "10"
    feel [over: func [f a o] [
            prompt/text: either a ["Deduct 1 for each Test"] ["Move sliders...Click Test."] show prompt]
        ] return
    vh4 gold "Rank: "   rank: vh4 "Thinking..." left
        feel [over: func [f a o] [
            prompt/text: either a ["ACE!, Expert, Geek or Nerd!"] ["Move sliders...Click Test."] show prompt]
        ] return pad -20x0
    do [
        r/data: b/data: g/data: 1.0
        r/color: g/color: b/color: 0
        targ/color rand-color
        r/pane/1/color: red
        g/pane/1/color: green
        b/pane/1/color: blue
    ]
]
;probe lay/size

view lay

Tuesday 6 March 2012

RGB - HSL converter

HSL is a method for describing a color with hue, saturation, and lightness. The following script permit to convert a color from RGB to HSL and vice versa.
Here the source:
REBOL [
    File:       %color-converter.r
    Date:       18-Apr-2011
    Title:       "Color converter (RGB to HSL v.v.)"
    Purpose:     {To convert RGB color values to HSL values v.v.
                and to show them visually}
    Author:     "Rudolf W. Meijer"
    Home:       http://users.telenet.be/rwmeijer
    E-mail:     rudolf.meijer@telenet.be
    Version:     1.0.0
    Comment:     "Needs RebGUI (http://www.dobeash.com/rebgui.html)"
    History: [
                0.1.0 [7-Apr-2011 {Start of project} "RM"]
                1.0.0 [18-Apr-2011 {First release} "RM"]
    ]
    license: {
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License (http://www.gnu.org/licenses)
for more details.
}
]
;---|----1----|----2----|----3----|----4----|----5----|----6----|----7----|-

; check that RebGUI is loaded
; ---------------------------

if exists? %rebgui.r [do %rebgui.r ]
unless value? 'ctx-rebgui [
    alert "RebGUI missing! Get it from http://rebgui.codeplex.com"
    halt
]
to-int: func [d [integer! decimal!]][to-integer round d]
to-hex: func [b [binary!]][rejoin ["#" copy/part at form b 3 6]]
hsl-rgb: func [
    hsl [tuple!]
    /local L S C H' X R G B mi
][
    either 3 <> length? hsl
    [
        0.0.0
    ][
        S: hsl/2 / 240
        L: hsl/3 / 240
        C: (1 - abs 2 * L - 1) * S
        H': mod hsl/1 / 40 6
        X: C * (1 - abs ((mod H' 2) - 1))
        set [R G B] case [
            H' < 1 [reduce [C X 0]]
            H' < 2 [reduce [X C 0]]
            H' < 3 [reduce [0 C X]]
            H' < 4 [reduce [0 X C]]
            H' < 5 [reduce [X 0 C]]
            H' < 6 [reduce [C 0 X]]
            true   [[0 0 0]]
        ]
        R: to-int R * 255
        G: to-int G * 255
        B: to-int B * 255
        mi: to-int L - (C / 2) * 255
        (to-tuple reduce [R G B]) + mi
    ]
]
rgb-hsl: func [
    rgb [tuple! binary!]
    /local R G B Ma mi C H' L S
][
    either 3 <> length? rgb
    [
        0.0.0
    ][
        R: rgb/1 / 255
        G: rgb/2 / 255
        B: rgb/3 / 255
        Ma: max max R G B
        mi: min min R G B
        C: Ma - mi
        H': case [
            C = 0   [0]
            Ma = R [mod G - B / C 6]
            Ma = G [B - R / C + 2]
            Ma = B [R - G / C + 4]
        ]
        L: Ma + mi / 2
        S: either C = 0 [0][C / (1 - abs 2 * L - 1)]
        to-tuple reduce [to-int H' * 40 to-int S * 240 to-int L * 240]
    ]
]
update-hsl: func [/local hsl clr ][
    hsl: rgb-hsl clr: to-tuple reduce [
        to-integer rfield/text
        to-integer gfield/text
        to-integer bfield/text
    ]
    set-text hfield to-string hsl/1
    set-text sfield to-string hsl/2
    set-text lfield to-string hsl/3
    if side/picked <= 2 [
        lresult/color: clr show lresult
        set-text lcolor clr
    ]
    if side/picked >= 2 [
        rresult/color: clr show rresult
        set-text rcolor clr
    ]
]
update-rgb: func [/local clr ][
    clr: hsl-rgb to-tuple reduce [
        to-integer hfield/text
        to-integer sfield/text
        to-integer lfield/text
    ]
    set-text rfield to-string clr/1
    set-text gfield to-string clr/2
    set-text bfield to-string clr/3
    if side/picked <= 2 [
        lresult/color: clr show lresult
        set-text lcolor clr
    ]
    if side/picked >= 2 [
        rresult/color: clr show rresult
        set-text rcolor clr
    ]
]
display "RGB to HSL v.v." compose [
    at   0x0 label -1 "R" bold
    at   6x0 rfield: spinner 12 options [0 255 8] data 0 [update-hsl]
    at 22x0 label -1 "G"   bold
    at 28x0 gfield: spinner 12 options [0 255 8] data 0 [update-hsl]
    at 44x0 label -1 "B"   bold
    at 50x0 bfield: spinner 12 options [0 255 8] data 0 [update-hsl]
    at   0x8 label -1 "H"   bold
    at   6x8 hfield: spinner 12 options [0 240 8] data 0 [update-rgb]
    at 22x8 label -1 "S"   bold
    at 28x8 sfield: spinner 12 options [0 240 8] data 0 [update-rgb]
    at 44x8 label -1 "L"   bold
    at 50x8 lfield: spinner 12 options [0 240 8] data 0 [update-rgb]
    at 28x16 text "Step size"
    at 50x16 spinner 12 options [1 10 1] data 8 [
        rfield/options/3: to-integer face/text
        bfield/options/3: to-integer face/text
        gfield/options/3: to-integer face/text
        hfield/options/3: to-integer face/text
        sfield/options/3: to-integer face/text
        lfield/options/3: to-integer face/text
    ]
    at 10x24 side: radio-group 48x5 data [2 "left" "both" "right"][
        switch face/picked [
            1 [
                set-text rfield to-string lresult/color/1
                set-text gfield to-string lresult/color/2
                set-text bfield to-string lresult/color/3
            ]
            3 [
                set-text rfield to-string rresult/color/1
                set-text gfield to-string rresult/color/2
                set-text bfield to-string rresult/color/3
            ]
        ]
        update-hsl
    ]
    at 0x32 panel data [tight
    lresult: box 31x62 black rresult: box 31x62 black]
    at   0x96 lcolor: text 31 "0.0.0" font [align: 'center]
    at 31x96 rcolor: text 31 "0.0.0" font [align: 'center] return
    at 23x103 button 16 "Exit" [quit]
] do-events