This is a blog about Rebol, it's a fantastic free programming language, it permits easily to create complete software with few lines of code. It's cross-platform, so if you write it on Windows, it will work on Linux and Mac, and vice-versa. You can produce also wonderful GUI with just 3 lines of code!
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
Tags:
GUI,
scientific
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:
Here an example, it's all in only one line:
Here the result:
You can find more about OTA bitmap here: http://en.wikipedia.org/wiki/OTA_bitmap
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:
Tags:
console
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:
And here an example, the following table:
It can be represented in CSV format this way:
Writing it on temp.csv file and using the above functions:
So it's extremely easy to retrieve data:
Or this way:
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:
You can modify your console, just look a this:
You can change the prompt symbol, the result symbol, the busy simbols, the tab size and lot more, try this:
>> 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:
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:
The following all digits:
The following check if there some number combination:
Uppercase chars:
Lowercase chars:
Another way to make all chars:
All chars and digits:
Control chars:
Hexadecimal values:
The TAB:
Linear white space (LWS), a combination of space and tab:
New line and carriage return, white spaces:
Punctuation:
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 THORNU+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 ONEThe 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:
or
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:
Here a couple of example:
view layout [ button black "Click me" ]
or
view layout [ button 0.0.0 "Click me"]
Here the result:
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:
| Name | Value | Color | Name | Value | Color | |
| aqua | 40.100.130 | base-color | 200.200.200 | |||
| beige | 255.228.196 | black | 0.0.0 | |||
| blue | 0.0.255 | brick | 178.34.34 | |||
| brown | 139.69.19 | coal | 64.64.64 | |||
| coffee | 76.26.0 | crimson | 220.20.60 | |||
| cyan | 0.255.255 | forest | 0.48.0 | |||
| gold | 255.205.40 | gray | 128.128.128 | |||
| green | 0.255.0 | ivory | 255.255.240 | |||
| khaki | 179.179.126 | leaf | 0.128.0 | |||
| linen | 250.240.230 | magenta | 255.0.255 | |||
| maroon | 128.0.0 | mint | 100.136.116 | |||
| navy | 0.0.128 | oldrab | 72.72.16 | |||
| olive | 128.128.0 | orange | 255.150.10 | |||
| papaya | 255.80.37 | pewter | 170.170.170 | |||
| pink | 255.164.200 | purple | 128.0.128 | |||
| reblue | 38.58.108 | rebolor | 142.128.110 | |||
| red | 255.0.0 | sienna | 160.82.45 | |||
| silver | 192.192.192 | sky | 164.200.255 | |||
| snow | 240.240.240 | tan | 222.184.135 | |||
| teal | 0.128.128 | violet | 72.0.90 | |||
| water | 80.108.142 | wheat | 245.222.129 | |||
| white | 255.255.255 | yellow | 255.255.0 |
Tags:
GUI
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
Tags:
GUI
Subscribe to:
Posts (Atom)