Thursday 26 January 2012

Chinese year

This script gives the Chinese year both in English and in French:


REBOL [
    Title: "Chinese Year"
    Version: 1.0.0
    Date: 9-Jan-2005
    File: %chinese-year.r
    Author: "Vincent Ecuyer"
    Purpose: "Chinese Year name"
    Language: 'en
    Usage: "Type in the year -> get the chinese year name"
    Comment: {
        Works under both /View and /Core,
        in english (language: 'en) and french (language: 'fr).
        Fonctionne sous /View et /Core,
        en anglais (language: 'en) et français (language: 'fr).
    }

]
language: system/script/header/language
locale-strings: [
    year [fr "Année: " en "Year: "]
    chinese-year [fr "Année chinoise: " en "Chinese Year: "]
    animal [fr [
        "Rat" "Boeuf" "Tigre" "Lièvre" "Dragon" "Serpent"
        "Cheval" "Chèvre" "Singe" "Coq" "Chien" "Porc"
    ] en [
        "Rat" "Ox" "Tiger" "Rabbit" "Dragon" "Snake"
        "Horse" "Goat" "Monkey" "Rooster" "Dog" "Pig"
    ]]
    element [fr [
        "de Bois" "de Bois" "de Feu" "de Feu" "de Terre"
        "de Terre" "de Métal" "de Métal" "d'Eau" "d'Eau"
    ] en [
        "Wood" "Wood" "Fire" "Fire" "Earth"
        "Earth" "Metal" "Metal" "Water" "Water"
    ]]
]
gui-strings: [
    l-year year
    l-chinese-year chinese-year
]
locale: func [value][copy select select locale-strings value language ]
set-text: func [face value][
    either face/text [append clear face/text value][face/text: copy value]
]
add-text: func [face value][
    either face/text [append face/text value][face/text: copy value]
]
mod-3: func [face value][
    if error? try [face: do trim face/text][face: 0]
    face: face - 3 // value
    either positive? face [face][face + value]
]
set-language: func [value][
    language: value
    foreach [label text] gui-strings [
        set-text get label locale text
        show get label
    ]
    if all [year/data not empty? year/data][do-calculs]
]
do-calculs: does [
    animal: mod-3 year 12
    element: mod-3 year 10
    set-text name-1 pick [
        "Jia" "Yi" "Bing" "Ding" "Wu"
        "Ji" "Geng" "Xin" "Ren" "Gui"
    ] element
    add-text name-1 "-"
    add-text name-1 pick [
        "Zi" "Chou" "Yin" "Mao" "Chen" "Si"
        "Wu" "Wei" "Shen" "Yu" "Xu" "Hai"
    ] animal
    set-text name-2 either find [fr] language [pick locale 'animal animal ][pick locale 'element element ]
    add-text name-2 " "
    add-text name-2 either find [fr] language [pick locale 'element element ][pick locale 'animal animal ]
    add-text name-2 pick [" (Yang)" " (Yin)"] odd? element
    show [name-1 name-2]
]
either all [value? 'view? view? value? 'layout][
    view layout [
        size 400x100
        style mini-label label 45x15 white font [
            size: 9 colors: [255.255.255 0.0.0]
        ]
        backcolor 255.82.41
        across
        l-year: label 46x19 locale 'year year: field 70 [do-calculs]
        return
        l-chinese-year: label 97x19 locale 'chinese-year
        name-1: text "" 70   center label "/"
        name-2: text "" 150 center
        at 300x0
        mini-label "English"   [set-language 'en]
        mini-label "Français" [set-language 'fr]
        do [focus year]
    ]
][
    name-1: make object! [text: none]
    name-2: make object! [text: none]
    year: make object! [text: none]
    show: func [value][
        value: append copy [] value
        foreach item value [
            item: get item
            if none? item/text [item/text: copy ""]
        ]
    ]
    forever [
        until [
            year/text: ask locale 'year
            if empty? year/text [quit]
            not error? try [to-integer year/text]
        ]
        do-calculs
        print rejoin [
            locale 'chinese-year
            name-1/text
            " / "
            name-2/text
        ]
    ]
]
;quit

Wednesday 25 January 2012

Graphical Internet Server Monitor

Carl Sassenrath wrote this script:
http://www.rebol.com/view/demos/gismo.r

I used that code to produce the simpler version:
Rebol []
time-out: 5 ; Seconds to wait for the connection (adjust it!)
poll-time: 0:00:10
system/schemes/default/timeout: time-out
system/schemes/http/timeout: time-out
sites: [
    ; List of URLs (http or tcp are allowed)
    http://www.rebol.com
    http://www.rebol.net
    http://www.rebol.org
    http://mail.rebol.net
    http://www.altme.com
    http://rebol2.blogspot.com/
]
;main layout
out: [
    backeffect [ gradient 0x1 black coal ]
    vh1 "Graphical Internet Server Monitor"
]
foreach site sites [
  append out (reduce ['text   (to-string site) ] )
]
append out [
    pad 50x0
    btn water 100 "Refresh" rate poll-time feel [
        engage: func [ f a e ] [
            if find [   time down   ]   a [check-sites ]
        ]
    ]
]
append out reduce ['vh4 yellow reform [ "Automatic refresh in" poll-time ] ]
check-sites: does [
    foreach face out/pane [
        if face/style = 'text [
            face/color: gray
            show face
            either attempt [ close open to-url face/text true ] [
                face/color: green
                show face
            ] [
                face/color: red
                show face
            ]
        ]
    ]
]
out: layout out
view out


Wait 10 seconds and this will be the result:

Tuesday 24 January 2012

TUI Dialect - A dialect to print ASCII sequences

I post here an interesting guide: Author: Ingo Hohmann


With REBOL 2.1 and on we got the ability to use ASCII sequences in REBOL's 'print statements, to control cursor behaviour. A really big step, because now we could do nifty things like:

print "^[[J^[[10;10HHello World!"


Which would, actually, clear the screen, put the cursor at position 10, 10 on the screen, and print "Hello World!". That's nice enough for REBOL to print, but not for me to write, or even understand later. So, what could be done to make writing those strings easier?

First Steps


A first idea could be to save the control sequences to some word, thus having:

cls: "^(1B)[J"


Now the above could be written as:
print rejoin [ cls "^[[10;10HHello World!"]


Which is better readable than our first version, but has two disadvantages:
  • words for the ascii strings clutter the global namespace
  • we can't do positioning strings like that, because the position has to be added into the ASCII sequence.

Next take:

we'll create a single function, with refinements for every ASCII command, like this:

cursor1: func [
    "Positions the cursor"
    /clear "clears the screen"
    /pos "sets cursor to position row, col"
    posi [pair! ]
    /local ret
] [
    pre: copy "^(1B)["
    any [
        all [
            clear ret: join pre "J"
        ]
        all [
            pos ret: join pre rejoin [
                posi/x ";" posi/y "H"
            ]
        ]
    ]
    ret
]


Now we can write our little "Hello World" message this way:
print rejoin [cursor1/clear cursor1/pos 10x10 "Hello World!" ]



What I didn't like about it, that was the "/" notation used, so I decided to settle to write a dialect to position the cursor.
A Cursor Positioning Dialect

Creating a dialect means, to create a now mini language, that can be used in a specialized environment within REBOL. This means, dialects are organized as blocks, which are not treated by the normal REBOL interpreter, but by an interpreter written in REBOL.

O.K. first what we'll gain:

print cursor2 [clear pos 10x10 "Hello World!" ]


This will print exactly the same as the string we started with, but it is much easier to understand, and change later, should the need arise.

Have I got you interested? Well, of course, because otherwise you wouldn't have proceded until here...

How to do it


First we'll need a function, that accepts a block:

cursor2: func [
    {Cursor positioning dialect (iho)}
    commands [
        block!
    ]
] [
]


Now we have to get this function interpret the block, this is best done with REBOLs block-parse ability:

cursor2: func [
    {Cursor positioning dialect (iho)}
    commands [
        block!
    ]
] [
    parse commands rules
]


And now all we need to do is fill in the rules ;-)

Let's proceed slowly, we have seen above, that we want to use specific words, to trigger output of the respective ASCII commands, let's give it a try:


rules: [
    any [
        'clear | 'at
    ]
]


Using this rule, our function will correctly parse a block containing any sequence of the words 'clear 'at:

cursor2: func [
    {Cursor positioning dialect (iho)}
    commands [
        block!
    ]
    /local rules
] [
    rules: [
        any [
            'clear | 'at
        ]
    ]
    parse commands rules
]


>> cursor2 [ clear at at clear at ]
== true


Nice, isn't it? But we need to be able to give the 'at command the actual coordinates to put the cursor, and, well, I'd like to be able to insert Text-strings right between the commands, so we need to parse looking for data-types: (While I'm only changing the rules block, I'll not print the whole function again ...)

rules: [
    any [
        'clear |
        'at set arg pair! |
        set arg string!
    ]
]

Now our dialect block can contain elements like

just the word 'clear
the word 'at, followed by a pair, this pair! will be saved into arg
strings

Let's give it a try again:

>> Cursor2 [ clear at 10x10 "Hi World!" ]
== true

Yup, so far it works, but now we want it to make some real output.

rules: [
    any [
        'clear (append string "^(1B)[J") |
        'at set arg pair! (append string rejoin ["^(1B)[" arg/x ";" arg/y "H"]) |
        set arg string! (append string arg)
    ]
]


Now, the part in parens is normal REBOL code, that gets executed, whenever the the part before it matches, now let's update our function with some things we need, and give it a try.

cursor2: func [
    {Cursor positioning dialect (iho)}
    commands [
        block!
    ]
    /local rules string arg
] [
    string: copy "" ; Don't forget 'copy here ...
    rules: [
        any [
            'clear (append string "^(1B)[J") |
            'at set arg pair! (append string rejoin ["^(1B)[" arg/x ";" arg/y "H"]) |
            set arg string! (append string arg)
        ]
    ]
    parse commands rules
    string
]


>> print Cursor2 [ clear at 10x10 "Hi World!" ]

Aaaahhhhh, it worked like a charm, here. Now, what have we done since the last time we looked at the function? We made some new words local, initialized an empty string, that holds the return value, and the last thing, we return this value. Great.

Now you could go ahead, read the REBOL documentation, and fill in words for other ASCII commands, but wait, I want to do some little fine-tuning, first.

Think about it, wouldn't it be nice, if we could include arbitrary REBOL Code within the dialect? Maybe like you want include a row of dashes, of computed length.

Let's add a command to repeat a given string:

rules: [
    any [
        'clear (append string "^(1B)[J") |
        'at set arg pair! (append string rejoin ["^(1B)[" arg/x ";" arg/y "H"]) |
        set cnt integer! set arg string! (append string head insert/dup copy "" arg cnt) |
        set arg string! (append string arg)
    ]
]


Let's try:

>> print cursor2 [ clear 10 "-" ]

It works, but where's the promised REBOL Code support? Just a wee little moment of patience. Here it is, the 'command function. All we actually have to do is run the dialect block through compose first, like this:

cursor2: func [
    {Cursor positioning dialect (iho)}
    commands [
        block!
    ]
    /local rules string arg
] [
    string: copy ""
    commands: compose commands ; NEW LINE HERE
    rules: [
        any [
            'clear (append string "^(1B)[J") |
            'at set arg pair! (append string rejoin ["^(1B)[" arg/x ";" arg/y "H"]) |
            set cnt integer! set arg string! (
append string head insert/dup copy "" arg cnt
) |
            set arg string! (append string arg)
        ]
    ]
    parse commands rules
    string
]


>> x: 10x10
== 10x10
>> print cursor2 [ clear at (x) "Hello World!" at 11x10 (length? "Hello World!") "-" ]

What I am still missing, I want to know about the screen size, for some computation, can we add this, too? Sure.

To get the screen-size, we first have to print the ASCII command, and then read the data from the console port, and understand it, of course. Here's what I want to add to our dialect function:

; Don't forget to add 'screen-size to our functions locals
screen-size: (
; for Rebol Version 1.3
; c: open/binary [scheme: 'console]
; for later versions (changes in port handling)
c: open/binary/no-wait [scheme: 'console]
prin "^(1B)[7n"
arg: next next to-string copy c
close c
arg: parse/all arg ";R"
forall arg [change arg to-integer first arg]
arg: to-pair head arg
)


So, we're setting screen-size to what the whole parent expression evaluates to. That's,

  • open port to the console
  • print the ASCII command for "get screen dimension"
  • get the return value (copy c)
  • convert it to a string - this will be something like "^[[48;110R" - 48 lines, 110 columns wide
  • skip the first two characters, and assign to arg
  • close the port
  • split the string, removing ";" and "R" - [ "48" "110" ]
  • change those values into integers!
  • and make a pair! from that block

Now we have the screen-dimensions as a block in 'screen-size, let's try it out:
>> print cursor2 [ clear (screen-size/y) "-" ]
** Script Error: screen-size has no value.
** Where: screen-size/y


That's not exactly what we wanted, is it? The problem here is, 'compose runs the code in the dialect in the global context, where screen-size isn't defined, because it's only local to cursor2. So we have to manually 'bind it to this functions context, to be able to access the value, it's done like this:

Change the line


commands: compose commands


to


commands: compose bind commands 'screen-size


This tells REBOL, whenever you find a word you don't understand while working on our command string, try to find it where you can find 'screen-size right now.
Time for a final version

This text is already much longer than I planned it, so maybe we should just have a look at the final version.

I included some more words in the dialect, and a limited error handling, but you'll see ...

cursor2: func [
    {Cursor positioning dialect (iho)} [
        catch
    ]
    commands [
        block!
    ]
    /local screen-size string arg cnt cmd c err
] [
    ; get the size of the screen
    screen-size: (
; for Rebol Version 1.3
; c: open/binary [scheme: 'console]
; for later versions (changes in port handling)
c: open/binary/no-wait [scheme: 'console]
prin "^(1B)[7n"
arg: next next to-string copy c
close c
arg: parse/all arg ";R"
forall arg [change arg to-integer first arg]
arg: to-pair head arg
)

    ; some setup
    string: copy ""

    ; I added this little func, so I don't have to write the start
    ; of all the commands over and over
    cmd: func [
        s
    ] [
        join "^(1B)[" s
    ]

    ; compose, so that () in the dialect gets reduced
    ; and catch any error within, then throw it again ...
    if error? set/any 'err try [
        commands: compose bind commands 'screen-size
    ] [
        throw err
    ]

    ; ready to parse the dialect now (I included the rules block directly)
    arg: parse commands [
        any [
            'direct set arg string! (append string arg) |
            'home (append string cmd "H") |
            'kill (append string cmd "K") |
            'clear (append string cmd "J") |
            'up set arg integer! (append string cmd [arg "A"]) |
            'down set arg integer! (append string cmd [arg "B"]) |
            'right set arg integer! (append string cmd [arg "C"]) |
            'left set arg integer! (append string cmd [arg "D"]) |
            'at set arg pair! (append string cmd [arg/x ";" arg/y "H" ]) |
            'del set arg integer! (append string cmd [arg "P"]) |
            'space set arg integer! (append string cmd [arg "@"]) |
            'move set arg pair! (append string cmd [arg/x ";" arg/y "H" ]) |
            set cnt integer! set arg string! (
append string head insert/dup copy "" arg cnt
) |
            set arg string! (append string arg)
        ]
        end
    ]

    ; ahh, maybe the user made an error when writing commands in
    ; the dialect? throw an error, then
    if not arg [
        throw make error! "Unable to parse block"
    ]

    ;return string to be printed
    string
]


Maybe you wondered about the [catch] in the functions header (or maybe you didn't even notice), what does it do? Instead of trying to describe it, I'll show you the error messages of two cursor2 runs, once with, and once without catch:

Without [catch]

>> print cursor2 [ clear (screen-size/y) "-" x ]
** Throw Error: ** User Error: Unable to parse block.
** Where: throw make error! "Unable to parse block"

With [catch] included

>> print cursor2 [ clear (screen-size/y) "-" x ]
** User Error: Unable to parse block.
** Where: cursor2 [clear (screen-size/y) "-" x]

You see, without [catch] the call of 'throw is displayed as originator of the error, whereas including [catch] displays the call of the dialect as source of the error. I think the latter is much more understandable to the user.

Final thoughts


Creating a dialect is like creating a new language, so you have to be careful about what words you use, and about the grammar.

For example, I started out with 'pos for positioning the cursor, but settled for 'at at last. Because I got into trouble. Is 'pos used to get or set the position? If it sets the position, and I have get-pos for getting, why is there no set-pos? So, better use 'at and 'where, in my opinion.

Some rules: words should be,
  • easy to remember
  • hard to misunderstand
  • short (?)

For the repeat string command, I haven't actually included a command, I wan't able to decide what to use

'repeat integer! string! (repeat 3 ".")
'repeat string! integer! (repeat "." 3)
'repeat string! 'x integer! (repeat "." x 3)
.
.
.


So I thought this is short, and understandable, and not likely to be misunderstood/misused.

And last, I return the string instead of printing it directly, this way you are free to save the string returned for later use, without the need to run the dialect again.

Monday 23 January 2012

Text list

Making wonderful interfaces is easy with Rebol, if you are looking for text list with a more options and a better customization, you can add this script to yours:
http://www.rebol.org/view-script.r?script=change-text-lists.r
and the result will be like this demo:



Every function and style is well described in the script.

Friday 20 January 2012

Rebol as web application

The power of Rebol can be used also for web application. There are many languages for this purpose: PHP, Javascript, Ruby. But no other language is easy, complete and small as Rebol.
To install on a webserver you must download the rebol core version from here (just 300kb):
http://www.rebol.com/download-core.html
Then you can copy in your webserver, for example in /usr/bin/.
To use it you webserver must be configured to use CGI script (all webserver usually permit CGI scripts).
Now You are ready to write your first web application, like this: (call it example.cgi)
#! /usr /bin /rebol-core -cs
Rebol [ title: "My first example" ]
print "Content-type: text/html^/"
print [ "REBOL CGI works!" "Time is: " now/time]


Now connect to your webserver, like www.myweb.com/example.cgi, and it'll appear on your browser like this:



The first 3 rows are mandatory:
  1. path to rebol core with option for CGI scripts
  2. Rebol header (rebol want it)
  3. HTML header (all webservers want it)
 You may discover further on Rebol CGI reading these pages:
 There are a lot of script ready to use for webserver, here a small list:

Tuesday 17 January 2012

"Le Compte Est Bon" game

"Le compt est Bon" ("the calculus is right") is a French game, the scope of the game is arriving to the target number using the number sequence with just the operator +,-,*,/ and the numbers or their results only one time.
I found this script that works good, but it's very hard to understand:

http://www.rebol.org/view-script.r?script=ceb.r
I tried to rewrite it in an easy way to understand, this is the result:

ceb: func [
    "Find the way to reach the target number using the numbers in list"
    list [ series! ]
    target [integer! ]
    /local op dv calculs nwlist
] [
    text: reform [ "Series:" list ", target number:" target newline ]
    sort list
    kronos: now/time
    op: [   + - * / ]
    dv: func [ x y ] [
        either all [( x <> 0 ) (y <> 0) ] [
                either (x // y) = 0 [ x / y ] [ 0 ]
        ] [
            0
        ]
    ]
    ;try to divide with no reminder, otherwise it returns zero
    calculs: func [
        x y
    ] [
        reduce [
            ( x + y) ( x - y) ( x * y) (dv x y)
        ]
    ]
    status: false
    find-sol: func [
        list text /local list2 list3 results
    ] [
        if status [
            exit
        ]
        foreach item list [
            if status [
                break
            ]
            list2: copy list
            alter list2 item ;we remove the item from a copy of the list
            foreach item2 list2 [
                if status [
                    break
                ]
                list3: copy list2
                alter list3 item2 ;we remove the item2 from a copy of the list2
                results: calculs item item2
                for i 1 4 1 [
                    if status [
                        break
                    ]
                    text2: append (copy text) (reform [item op/:i item2 "=" results/:i newline ])
                    if results/:i = target [
                        status: true print text2 print reform [
                            "time elapsed: " ( now/time - kronos )
                        ]
                    ]
                    list4: append (copy list3) results/:i ;add one of the reults to the list of numbers to use
                    if (length? list4) >= 2 [
                        find-sol list4 text2
                    ]
                ]
            ]
        ]
    ]
    find-sol list text
    if status = false [
        print "Sorry, I didn't find any solution."
    ]
]

Here an example of how it works:

>> ceb [ 1 2 3 4 ] 27
Series: 1 2 3 4 , target number: 27
2 * 4 = 8
1 + 8 = 9
3 * 9 = 27
time elapsed: 0:00

>> ceb [ 3 6 25 50 75 100 ] 698
Series: 3 6 25 50 75 100 , target number: 698
3 + 6 = 9
75 * 9 = 675
25 + 675 = 700
100 / 50 = 2
700 - 2 = 698
time elapsed: 0:00:18


Can you find a more elegant solution? ;-)

Tuesday 10 January 2012

VID keycodes and shortcuts

Sometimes a GUI needs a key shortcuts, for example CTRL+S to save a file, how to do this job with Rebol?
It's easy, just use the key word:

view layout [
text "Press A or B keys"
key #"a"   [ alert "You pressed a"]
key #"A"   [alert "You pressed A"]
key keycode [#"b" #"B"] [alert "You pressed b or B"]
]


The word keycode is used for more than one key or for special keys:
view layout [
text "Press PageUp or PageDown keys"
key keycode [page-up page-down] [alert "You pressed PageUp or PageDown"]
]

The CTRL button is represented with the letter pressed and the symbol ^:
view layout [
text "Press CTRL+S"
key #"^S" [alert "You pressed CTRL+S"]
]

Special key table:
KeyCode
Insinsert
Canc#"^~"
Home home
End end
PageUp page-up
PageDownpage-down
Left arrowleft
Right arrowright
Up arrowup
Down arrowdown
Space#" "
TAB#"^-"
CTRL+S#"^S"

If you need to intercept also SHIFT with CTRL, is possible, but a little more complicated; you need to use the event:
view layout [
the-box: box "A Box" forest feel [
engage: func [face action event] [
if   event/shift and (event/key = #"^S")   [ print "You pressed CTRL+SIFT+S"]
]]
do [focus the-box]
]

event/shift and event/control check SHIFT and CTRL keys

Monday 9 January 2012

Catch game

Here the source of a very simple game, move your brick using the arrows to touch the falling bricks:
You can use up and down arrow to change game speed. Please notice the use of key to assign a function to a keyboard key, and keycode to use special button like the arrows:
REBOL [
title: "Catch Game"
date: 30-Apr-2010
file: %catch-game.r
author:   Nick Antonaccio
purpose: {
A tiny game to demonstrate the basics of VID.
Taken from the tutorial at http://re-bol.com
}
]
alert "Arrow keys move left/right (up: faster, down: slower)"
random/seed now/time   speed: 11   score: 0
view center-face layout [
size 600x440   backdrop white   across
at 270x0 text "Score:"   t: text bold 100 (form score)
at 280x20   y: btn 50x20 orange
at 280x420 z: btn 50x20 blue
key keycode [left] [z/offset: z/offset - 10x0   show z]
key keycode [right]   [z/offset: z/offset + 10x0   show z]
key keycode [up]   [speed: speed + 1]
key keycode [down]   [if speed >   1 [speed: speed - 1]]
box 0x0 rate 0 feel [engage: func [f a e] [if a = 'time [
y/offset: y/offset + (as-pair 0 speed)   show y
if y/offset/2 > 440 [
y/offset: as-pair (random 550) 20   show y
score: score - 1
]
if within? z/offset (y/offset - 50x0) 100x20 [
y/offset: as-pair (random 550) 20   show y
score: score + 1
]
t/text: (form score)   show t
]]]
]

Thursday 5 January 2012

Adress book

Here an example of a simple and effective address book:
Here the source code:
REBOL [
    title: "Card File"
    date: 5-Mar-2010
    file: %card-file.r
    author: Nick Antonaccio
    purpose: { This is the quintessential simple text field storage application. It can be used as shown here, to save contact information, but by adjusting just a few lines of code and text labels, it could be easily adapted to store recipes, home inventory information, or any other type of related pages of data. A version of this script with line-by-line documentation is available at http://re-bol.com }
    ]
write/append %data.txt ""
database: load %data.txt
view center-face gui: layout [
    text "Load an existing record:"
    name-list: text-list blue 400x100 data sort (extract database 4) [
        if value = none [return]
        marker: index? find database value
        n/text: pick database marker
        a/text: pick database (marker + 1)
        p/text: pick database (marker + 2)
        o/text: pick database (marker + 3)
        show gui
        ]
    text "Name:" n: field 400
    text "Address:" a: field 400
    text "Phone:" p: field 400
    text "Notes:" o: area 400x100
    across
    btn "Save" [
        if n/text = "" [alert "You must enter a name." return]
        if find (extract database 4) n/text [
            either true = request "Overwrite existing record?" [
                remove/part (find database n/text) 4
                ] [return ]
            ]
        save %data.txt repend database [n/text a/text p/text o/text]
        name-list/data: sort (extract copy database 4)
        show name-list
        ]
    btn "Delete" [
        if true = request rejoin ["Delete " n/text "?"] [
            remove/part (find database n/text) 4
            save %data.txt database
            do-face clear-button 1
            name-list/data: sort (extract copy database 4)
            show name-list
            ]
        ]
    clear-button: btn "New" [
    n/text: copy ""
    a/text: copy ""
    p/text: copy ""
    o/text: copy ""
    show gui
    ]
]