Monday 16 September 2013

Alternative requesters

Rebol has many built in requester, today I'll show you some different requesters:

request-date


The following request date can be customized in every aspect:

Here is the source code:
REBOL [
    title: "request-date object/func optimization and enhancment"
    file: %request-date.r
    Author: "Didier Cadieu"
    email: to-email rejoin ["Didec" #"@" "wanadoo.fr"]   ; (f.ck the bot)
    date: 23-dec-2003
    version: 1.1
    purpose: {
        This is an enhanced replacement for the original request-date function,
        the embedded date picker in view (datepicker).
       
        - Clean, correct and optimize the code.
        - add day names at top of window (use system/locales/days).
        - add first-day-of-week value to choose starting with Sunday
          or Monday.
          (I think this value should be part of system/locales)
        - add Today button at bottom.
        - Today is shown with red circle in calendar.
       
        - New refinment:   'request-date/date a-date   to initialize the calendar.
          This date is shown with red square in calendar, and is
          retuned instead of none if the window is closed.
         
        WARNING ! It needs View 1.2.8+ to work
    }  
]
;***** MOD function will be included in View 1.3
; Here is a quick define for older version
if not value? 'mod [mod: func [a b][a // b]]
req-funcs: make req-funcs [
    req-date: make object! [
        base: date-lay: last-f: mo-box: today-draw: this-draw: result: none
        cell-size: 24x24
        ; NEW WORD: DETERMINE FIRST DAY OF WEEK (1=monday or 7=sunday)
        ; THE BETTER WILL BE TO ADD THIS WORD TO system/locales
        ; IT COULD BE INITIALIZE ACCORDING TO THE O.S. VALUE (if possible).
        first-day-of-week: 7
       
        ; THE COMPUTATION WAS CHANGED TO MANAGE FIRST-DAY-OF-WEEK
        ; AND AVOID HAVING AN EMPTY FIRST LINE
        calc-month: func [/local month bas tod d][
            bas: base
            month: bas/month
            bas/day: 1
            bas: bas - (mod bas/weekday 14 - first-day-of-week) + mod first-day-of-week 7
            tod: now/date
            foreach face skip date-lay/pane 11 [
                either bas/month <> month [face/text: none] [
                    face/text: bas/day
                    d: copy either bas = tod [today-draw][[]]
                    if bas = result [append d this-draw]
                    face/effect: compose/only [draw (d)]
                ]
                bas: bas + 1
            ]
            mo-box/text: md base
            show [date-lay mo-box]
        ]
        md: func [date][join pick system/locale/months date/month [" " date/year]]
        init: func [/local cell-feel offs fon cs2][
            if none? base [base: now/date]
            fon: make face/font [valign: 'middle align: 'center]
            cell-feel: make face/feel [
                over: func [f a] [
                    f/color: either all [a f/text] [yellow] [f/color2]
                    show f
                ]
                engage: func [f a e] [
                    if all [a = 'down f/text] [
                        either f/data [base: f/data][base/day: f/text]
                        f/color: f/color2 result: base hide-popup
                    ]
                ]
            ]
           
            cs2: cell-size   / 2
            today-draw: reduce ['pen red 'circle cs2 - 1 cs2/x - 3 'circle cs2 cs2/x - 3]
            this-draw: reduce ['pen red 'box 1x1 cell-size - 2x2]
           
            date-lay: layout [
                size cell-size * 7x9
                origin 0x0 space 0
                across
                arrow left cell-size [base/month: base/month - 1 calc-month]
                mo-box: box cell-size * 5x1 md base font [size: 12]
                arrow right cell-size [base/month: base/month + 1 calc-month]
                return
                offs: at
                at cell-size * 0x8
                box rejoin ["Today: " now/date] cell-size * 7x1 with [
                    color2: color font: fon
                    effect: compose/only [draw (today-draw)] feel: cell-feel
                    data: now/date
                ]
            ]
            last-f: func [num][
                append date-lay/pane make face [
                    offset: offs size: cell-size feel: edge: none
                    text: copy/part pick system/locale/days num 2
                ]
                offs/x: offs/x + cell-size/x
            ]
            last-f first-day-of-week
            repeat slot 6 [last-f first-day-of-week // 7 + slot 2]
            offs: offs + cell-size * 0x1
           
            last-f: none
            repeat slot 42 [
                append date-lay/pane make face [
                    offset: offs size: cell-size color: color2: white
                    font: fon feel: cell-feel data: edge: none
                ]
                offs/x: offs/x + cell-size/x
                if zero? slot // 7 [offs: offs + cell-size * 0x1]
            ]
            calc-month
        ]
        set 'request-date func [
            "Requests a date."
            /date dat [date!] "Initial date to show"
            /offset xy [pair!]
        ][
            ; ON CLOSE WITHOUT SELECTION, IF /DATE, RETURN "DAT" ELSE RETURN NONE
            base: any [result: either date [dat][none] now/date]
            either none? date-lay [init][calc-month]
            either offset [inform/offset date-lay xy] [inform date-lay]
            result
        ]
    ]
]
;***************** TEST-CODE ******************
; Delete from here to end to use in your own script

sl-en: make system/locale []
sl-fr: make system/locale [
    months: [
        "Janvier" "Février" "Mars" "Avril" "Mai" "Juin"
        "Juillet" "Août" "Septembre" "Octobre" "Novembre" "Décembre"
    ]
    days: ["Lundi" "Mardi" "Mercredi" "Jeudi" "Vendredi" "Samedi" "Dimanche" ]
]
view layout [
    style tx text 100 right
    vh3 "Test request-date"
    across
    tx "Locales:"
    rotary "English" "French" [
        system/locale: select reduce ["English" sl-en "French" sl-fr] face/text
        ; Reinitialize the layout
        req-funcs/req-date/date-lay: none
    ] return
    tx "First day of week:"
    rotary "Sunday" "Monday" [
        req-funcs/req-date/first-day-of-week: select ["Sunday" 7 "Monday" 1] face/text
        ; Reinitialize the layout
        req-funcs/req-date/date-lay: none
    ] return
   
    button 208 "Request-date" [f-r/text: form request-date show f-r] return
    button 208 "Request-date/date result" [
        if any [empty? f-r/text "none" = f-r/text] [f-r/text: now/date]
        f-r/text: to string!   request-date/date to date! f-r/text
        show f-r
    ] return
    tx "Result:" f-r: field 100
]

request-dir

Very nice and made all in Rebol, so it's absolutely cross-platform:

Here is the source code:

REBOL [
    file: %request-dir.r
    title: "Directory selector (treeview)"
    name:
    author: "Didier CADIEU"
    email: didec@wanadoo.fr
    date: 11-09-2003
    version: 1.0.0
    needs: {Work only on View 1.2.8+}
    purpose: {
        Open a requestor to select a directory.
        The current directories path is shown as a tree, and sub-dirs are shown for selection.
    }
    comment: {
        The make-dir button does not work as you can expect due to a bug in the management
        of modale window in view : the directory is created only when the function return.
       
        You can use the patch from Romano Paolo Tenca to correct this behaviour.
       
        This script is based on a work from Carl Sassenrath, found in the Mailing list
    }
]
ctx-req-dir: context [
    max-dirs:
    cnt: 0
    f-list:
    f-txt:
    f-slid:
    f-path:
    path:
    last-path:
    result:
    dirs: none
   
    list-data: copy []
    links: [[draw [pen 0.0.0 line 6x0 6x9 12x9]] [draw [pen 0.0.0 line 6x0 6x18 line 6x9 12x9]] ]
    lib: pth: lev: none
    dec: 11
   
    dirout: [
        origin 8x8 space 0x0
        vh3 "Select a directory"
        across pad 0x4
        f-list: list 300x292 180.180.180 [
            origin 0 space 0 across
            box 16x18
            f-txt: text 300 font-size 11 font [colors: [0.0.0 0.0.0]] [chg-dir face/user-data]
        ] supply [
            count: count + cnt
            if count > length? list-data [face/show?: false exit]
            face/show?: true
            set [lib pth lev] pick list-data count
            either index = 1 [
                face/offset/x: lev - dec
                face/effect: pick links not attempt [(third pick list-data count + 1) = lev]
            ] [
                face/text: lib
                face/color: pick [240.240.240 220.220.220] odd? count
                face/offset/x: lev
                if path = face/user-data: pth [face/color: 255.190.80 250.150.150]
            ]
        ]
       
        f-slid: scroller 16x292 [
            c: to-integer value * ((length? list-data) - max-dirs)
            if c <> cnt [cnt: c show f-list]
        ] return
        space 60x4
        f-path: field wrap font-size 11 316x40 [
            value: attempt [to-rebol-file to-file f-path/text]
            if all [value exists? value] [path: value show-dir]
        ] return
        btn-enter 65 "Open" [result: dirize path hide-popup]
        btn 65 "Make Dir" [
            value: request-text/title "Directory name:"
            if value [
                trim value
                if not empty? value [
                    either error? try [make-dir rejoin [dirize path value]] [
                        alert "Cannot create directory."
                        path: copy last-path
                    ] [chg-dir path]
                ]
            ]
        ]
        btn-cancel 65 "Cancel" [hide-popup]
    ]
   
    chg-dir: func [file][
        if none? file [exit]
        last-path: copy path
        path: copy file
        show-dir
    ]
    ; build a tree of dirs from first to last in the path, recursively
    build-tree: func [p /local b l] [
        b: split-path p
        l: 0
        if not none? second b [l: dec + build-tree first b]
        either b/2 [any [slash <> last b/2 remove back tail b/2]][change at b 2 "(root)"]
        append/only list-data reduce [any [second b "(root)"] p l]
        l
    ]
   
    show-dir: has [l d] [
        ; read contents of path
        dirs: attempt [load dirize path]
        if not dirs [
            path: last-path
            if not dirs: attempt [load dirize path][
                alert reform ["Invalid directory:" path]
                dirs: load path: %/
            ]
        ]
        ; keep only sub-dirs
        remove-each file dirs [slash <> last file]
        clear list-data
        ; recontruct the tree for the path
        l: dec + build-tree path
        ; append the sub-dirs
        foreach file sort dirs [
            replace/all file #"/" ""
            append/only list-data reduce [file rejoin [dirize path file] l]
        ]
        ; show everything
        f-path/text: any [attempt [to-local-file path] copy ""]
        f-slid/redrag max-dirs / max 1 length? list-data
        f-slid/step: either 0 >= d: (length? list-data) - max-dirs [0][1 / d]
        f-slid/data: 0.0
        cnt: 0
        show [f-list f-slid f-path]
    ]
    set 'request-dir func [
        "Requests a directory using pseudo treeview."
        /keep "Keep previous directory path"
        /dir "Set starting directory" where [file!]
        /offset xy /local
    ][
        if block? dirout [
            dirout: layout dirout
            max-dirs: to-integer f-list/size/y - 4 / f-txt/size/y
            center-face dirout
        ]
        if not all [keep path] [path: any [where what-dir]]
        if all [not empty? path slash = last path][remove back tail path]
        last-path: path
        result: none
        show-dir
        either offset [inform/offset dirout xy][inform dirout]
        result
    ]
]

request-list

Very useful request that support any type of string:

Here is the source code:

rebol [
    Title: "Request List Enhanced"
    Date:   10-Dec-2005
    Author: ["Mike Yaunish"]
    Version: 0.9.1
    Email: [%mike.yaunish--shaw--ca]
    file: %request-list-enhanced.r
    Comment: {Text-list Improvements by Carl Sassenrath & Updates by Paul Tretter.
              request-list-auto-fill from REBOL mailing list author unknown.
              request-list-enhanced by Mike Yaunish.
    }
    Rights: "Copyright 2000-2005 REBOL Technologies. All rights reserved."
    License: {
        Users can freely modify and publish this code under the condition that it is
        executed only with languages from REBOL Technologies, and user must include this
        header as is. All changes may be freely included by other users in their software
        (even commercial uses) as long as they abide by these conditions.
    }
    Purpose: {
        An enhancement to the regular request-list that allows selecting items from a request list
        by typing in the first few characters of the item. Works with text, word and number lists.
        Designed to make optimum use of the keyboard.
        - New refinement request-list-enhanced/return-index will return the index of the item not the value.
        - Keys used; cursor up, down, page-up, page-down, control+home, control+end, escape
    }            
    History: [
        0.9.0 [ 9-Dec-2005 {Initial beta version published to rebol.org} mike.yaunish@shaw.ca ]
        0.9.1 [12-Dec-2005 {Changed the following behaviours so that the user can't escape without a valid selection:
                            - Changed the behaviour when the enter key is pressed with a non-matching string.
                            - Added handling of tab key and shift+tab to move up and down the list.}
        ]
    ]
]

request-list-enhanced-ctx: make object! [
    request-list-styles: stylize [
        request-list-auto-fill: field with [
            feel: make feel [
                engage: func [
                    face act event index
                ] [
                    switch act [
                        down [
                            either face <> system/view/focal-face [
                                focus face
                            ] [system/view/highlight-start: system/view/highlight-end: none system/view/caret: offset-to-caret face event/offset show face ]
                        ]
                        over [
                            if system/view/caret <> offset-to-caret face event/offset [
                                if not system/view/highlight-start [
                                    system/view/highlight-start: system/view/caret
                                ]
                                system/view/highlight-end: system/view/caret: offset-to-caret face event/offset show face
                            ]
                        ]
                        key [
                            ctx-text/edit-text face event act
                            ; Added these event keys here because insert-event-func has caused some
                            ; problems with previously opened windows.
                            switch event/key [
                                down [move-selection 1]
                                #"^-" [; tab key
                                    either event/shift [
                                        move-selection -1    
                                    ][move-selection 1 ]                
                                ]
                                page-down [move-selection (a-text-list/lc - 1)]
                                page-up [move-selection (-1 * ( a-text-list/lc - 1) )]
                                home [
                                    if event/control [move-selection (-1 * (length? a-text-list/data))]
                                ]
                                end [if event/control [move-selection (length? a-text-list/data)]
                                ]
                                up [move-selection -1]
                                #"^M" [; return key
                                    face/action face face/text
                                ]
                            ]      
                            if all [char? event/key not empty? face/text find ctx-text/keys-to-insert event/key ] [search face ]
                        ]
                    ]
                ]
            ]
            search: func [face /local word ] [
                word: copy face/text
                foreach item face/user-data [
                    if equal? word copy/part item (
                        length? word
                    ) [
                        face/text: copy item system/view/focal-face: face system/view/highlight-start: skip face/text length? word system/view/highlight-end: tail face/text system/view/caret: tail face/text
                        show face
                        if flag-face? face search-action [
                            face/search-action face
                        ]
                        exit
                    ]
                ]
            ]
            words: [
                data [
                    new/user-data: second args next args
                ]
                search-action [flag-face new search-action args ]
            ]
        ]
        ; end of request-list-auto-fill style. ********************************************************************************************************************

        request-text-list: txt 200x200 with [
            feel: none
            color: snow
            colors: reduce [snow snow - 32   ]
            sz: ; size of the list window
            iter: ; the text face displayed on each line
            sub-area: ; the face that shows the list
            sld: ; scroll bar face
            sn: ; scroll bar integer offset into the data
            lc: ; lines of text to display
            picked: ; selected items
            picked-index: ; current index of picked item
            cnt: ; current index into the data
            act: ; action taken on click
            action-single: ; action taken on single click
            slf: ; pointer to list-face (self)

            text-pane: func [face id ] [
                if pair? id [
                    return 1 + second id / iter/size
                ]
                iter/offset: iter/old-offset: id - 1 * iter/size * 0x1
                if iter/offset/y + iter/size/y > size/y [return none ]
                cnt: id: id + sn
                if iter/text: pick data id [
                    if flag-face? slf format [
                        iface: slf/iter reduce first iter-format
                    ]
                    iter
                ]
            ]
            update: has [item value old-sn cur-index old-index ] [
                sld/redrag lc / max 1 length? data
                if item: find data picked/1 [
                    old-sn: sn
                    cur-index: index? item
                    if not all [( cur-index > old-sn ) ( cur-index < ( old-sn + lc + 1 )) ] [
                        either cur-index <= old-sn [
                            sn: max (cur-index - 1) 0
                        ] [sn: cur-index - lc ]
                        old-index: cur-index
                    ]
                    sld/data: ((max 1 sn) / (length? data) )
                ] [
                    sld/value: 0.0
                    pane/offset: 0x0
                ]
                self
            ]
            resize: func [new /x /y /local tmp ] [
                either any [
                    x y
                ] [
                    if x [
                        size/x: new
                    ]
                    if y [size/y: new ]
                ] [
                    size: any [
                        new size
                    ]
                ]
                pane/size: sz: size
                sld/offset/x: first sub-area/size: size - 16x0
                sld/resize/y: size/y
                iter/size/x: first sub-area/size - sub-area/edge/size
                lc: to-integer sz/y / iter/size/y
                self
            ]
            append init [
                sz: size
                sn: 0
                slf: :self
                act: :action
                if none? data [ data: any [ texts copy [] ]
                ]
                picked: copy [
                ]
                iter: make-face/size 'txt sz * 1x0 + -16x20
                iter/para: make self/para [origin: 2x0 ]
                iter/font: make self/font [
                ]
                lc: to-integer sz/y / iter/size/y: second size-text iter
                iter/feel: make iter/feel [
                    redraw: func [
                        f a i
                    ] [
                        iter/color: color
                        if flag-face? slf striped [
                            iter/color: pick next colors odd? cnt
                        ]
                        if all [find picked iter/text cnt = picked-index ] [iter/color: svvc/field-select ]
                    ]
                    engage: func [f a e ] [
                        if a = 'down [
                            if cnt > length? slf/data [
                                exit
                            ]
                            ; If not extended selection, clear other selections:
                            if not e/control [f/state: cnt clear picked ]
                            alter picked f/text
                            picked-index: cnt
                            if flag-face? slf single-click [do :single-click-action slf f/text ]
                            if e/double-click [do :act slf f/text ]
                        ]
                        if a = 'up [f/state: none ]
                        show pane
                    ]
                ]
                pane: layout/size [
                    origin 0 space 0
                    sub-area: box slf/color sz - 16x0 ibevel with [
                        pane: :text-pane
                    ]
                    at sz * 1x0 - 16x0
                    sld: scroller sz * 0x1 + 16x0 [
                        if sn = value: max 0 to-integer value * ((
                                1 + length? slf/data
                            )
                            - lc
                        ) [
                            exit
                        ]
                        sn: value
                        show sub-area
                    ]
                ]
                size
                pane/offset: 0x0
                sld/redrag lc / max 1 length? data
            ]
            words: [
                data [
                    new/text: pick new/texts: second args 1 next args
                ]
                striped [flag-face new striped args ]
                single-click [flag-face new single-click args ]
                format [flag-face new format iter-format: next args ]
            ]
        ]
    ]
   
    select-this-item: func [new-index] [
        a-text-list/picked-index: new-index
        a-text-list/picked: reduce [to-string ( pick a-text-list/data a-text-list/picked-index )]
        show a-text-list/update
        a-field/text: copy first a-text-list/picked
        show a-field
        focus a-field
    ]
   
    move-selection: func [direction /local new-index] [
        new-index: ((a-text-list/picked-index) + direction)
        if (new-index < 1) [
            new-index: 1
        ]
        if (new-index > (length? a-text-list/data)) [new-index: length? a-text-list/data ]
        select-this-item new-index
    ]
   
    set 'request-list-enhanced func [
        titl [ string!] {Title of requester}
        alist [block! ] {List of data}
        /offset where [pair!]   "xy -- Offset of window on screen"
        /return-index "return the index value"
        /local return-value all-strings orig-alist
    ] [
        all-strings: true
        orig-alist: copy alist
        alist: copy []
        foreach i orig-alist [
            either type? i <> string![
                all-strings: false
                append alist to-string i        
            ][append alist i ]                
        ]
        inform/title/offset l: layout [
            styles request-list-styles
            a-text-list: request-text-list
            single-click ; default action is double-click
            with [
                single-click-action: func [
                    f v
                ] [
                    a-field/text: copy first a-text-list/picked show a-field
                    focus a-field
                ]
            ]
            data alist [
                ; double-click-action
                return-the-selection
            ]
            across
            a-field: request-list-auto-fill data alist search-action
            with [
                search-action: func [f] [
                    a-text-list/picked-index: index? find a-text-list/data f/text
                    a-text-list/picked: reduce [to-string ( pick a-text-list/data a-text-list/picked-index) ]
                    show a-text-list/update
                ]
            ] [return-the-selection ]
            return
            button "OK" [return-the-selection   ]
            button "CANCEL" keycode escape [return-the-selection/value none ]
            do [
                return-the-selection: func [ /value the-value ] [
                    either value [
                        return-value: the-value
                        hide-popup
                    ][
                        either (a-field/text = first a-text-list/picked) [
                            either return-index [
                                return-value: a-text-list/picked-index
                            ] [
                                either not all-strings [
                                    return-value: pick orig-alist a-text-list/picked-index
                                ][return-value: first a-text-list/picked ]                
                               
                            ]
                            hide-popup
                        ][focus a-field ]      
                    ]
                ]
                select-this-item 1
            ]
        ] titl either offset [where] [system/view/screen-face/size - l/size / 2 ]
        return return-value
    ]
]
; *** end of object ***

demo: does [
    sample-word-list: sort first system/words
    sample-numeric-list: [ 1 2 3 4 12 13 14 15 31 32 33 34 35 36 125 305 315 344 678 987 1003 ]
    sample-text-list: []
    foreach i first system/words [append sample-text-list to-string i ]
    sort sample-text-list
    view layout [
        across
        button 150 keycode 'F3 "word list ^-(F3)" [ g/text: type? f/text: request-list-enhanced "Type some text in:" sample-word-list   show [ f g ]] return
        button 150 keycode 'F4 "text list ^-(F4)" [g/text: type? f/text: request-list-enhanced "Type some text in:" sample-text-list   show [ f g ]] return
        button 150 keycode 'F5 "numberic ^- (F5)" [g/text: type? f/text: request-list-enhanced "Type some numbers in:" sample-numeric-list   show [ f g ] ] return
        button 150 keycode 'F6 "return-index ^- (F6)" [g/text: type? f/text: request-list-enhanced/return-index "Type some text in:" sample-text-list   show [ f g ] ] return
        return
        label "return type:" g: field   return
        label "return value:" f: field
       
    ]
]
; uncomment line below to see how it works
demo halt

request-time

Very nice requester, to use it you must give a time:
request-time 13:21:32

Here is the source code:

rebol[
    file: %request-time.r
    Title: "request time"
    Author: "Tom Conlin"
    Date: 1-Mar-2003
    Purpose: "widget to return a valid time datatype"
    example: [do %request-time.r request-time 4:20]
]
req-time-ctx: make object! [
    time-lay: none
    result: none
   
; precomputed endpoints
big: [
87x5 95x6 103x8 110x11 117x15 124x19 130x24 136x30 141x36 145x42 149x50 152x57
154x65 155x73 156x80 155x87 154x95 152x103 149x110 145x117 141x124 136x130
130x136 124x141 117x145 110x149 103x152 95x154 87x155 80x156 73x155 65x154
57x152 50x149 42x145 36x141 30x136 24x130 19x124 15x118 11x110 8x103 6x95 5x87
4x80 5x73 6x65 8x57 11x50 15x42 19x36 24x30 30x24 36x19 42x15 50x11 57x8 65x6
73x5 80x4]
lil: [
85x29 90x30 96x31 101x33 105x35 110x38 114x42 118x46 122x50 125x54 127x59 129x64
130x70 131x75 132x80 131x85 130x90 129x96 127x101 125x105 122x110 118x114 114x118
110x122 105x125 101x127 96x129 90x130 85x131 80x132 75x131 70x130 64x129 59x127
54x125 50x122 46x118 42x114 38x110 35x106 33x101 31x96 30x90 29x85 28x80 29x75
30x70 31x64 33x59 35x54 38x50 42x46 46x42 50x38 54x35 59x33 64x31 70x30 75x29
80x28]
sec: [
88x4 96x5 103x7 111x10 118x14 125x18 131x23 137x29 142x35 146x42 150x49 153x57
155x64 156x72 157x80 156x88 155x96 153x103 150x111 146x118 142x125 137x131
131x137 125x142 118x146 111x150 103x153 96x155 88x156 80x157 72x156 64x155
57x153 49x150 42x146 35x142 29x137 23x131 18x125 14x118 10x111 7x103 5x96 4x88
3x80 4x72 5x64 7x57 10x49 14x42 18x35 23x29 29x23 35x18 42x14 49x10 57x7 64x5
72x4 80x3]
edg: [
88x1 96x2 104x4 112x7 119x11 127x16 133x21 139x27 144x33 149x40 153x48 156x56
158x64 159x72 160x80 159x88 158x96 156x104 153x112 149x119 144x127 139x133
133x139 127x144 119x149 112x153 104x156 96x158 88x159 80x160 72x159 64x158
56x156 48x153 40x149 33x144 27x139 21x133 16x127 11x120 7x112 4x104 2x96 1x88
0x80 1x72 2x64 4x56 7x48 11x40 16x33 21x27 27x21 33x16 40x11 48x7 56x4 64x2
72x1 80x0]
tic-toc: func "emit DRAW clock face @ time t" t[time!]/local h m s drw-blk radius][
    radius: 80x80
    drw-blk: make block! 256
    insert drw-blk
    either t < 12:00
        [[pen white fill-pen white]]
        [[pen black fill-pen black]]
    for i 1 60 1[
        either zero? i // 5
        [insert tail drw-blk compose[circle (sec/:i) 2]]       ; hour marks
        [insert tail drw-blk compose[line   (sec/:i) (edg/:i)]]; minute marks
    ]
    s: either zero? t/3 [60][t/3]
    m: either zero? t/2 [60][t/2]
    h: add multiply t/1 // 12 5 to integer! divide t/2 12
    h: either zero? h [60][h]
    insert tail drw-blk compose; hands
        pen red   line   (RADIUS) (lil/:h)
        pen blue line   (RADIUS) (big/:m)
        pen yellow line (RADIUS) (sec/:s)
    ]
    drw-blk
]
the-time: func [start [time! none!] /local lbl alm alarm civil][
    either start [alarm: start][alarm: now/time]
    civil: either greater-or-equal? alarm 13:00:00
        [alarm // 12:00:00]
        [either zero? alarm/1[alarm + 12:00][alarm]]
    time-lay: layout [
        origin 0x0
        across
        panel [ size 220x160
            across
            lbl: label 180 coal rejoin[civil either lesser? alarm 12:00 [" AM"][" PM"]tab tab alarm]
            return
            label 60 "Hours:"
            slider 120x16 gray red with[data: alarm/1 / 24]
            [alarm/1: minimum 23 to integer! value * 24
                civil: either greater-or-equal? alarm 13:00:00
                    [alarm // 12:00:00]
                    [either zero? alarm/1[alarm + 12:00][alarm]]
                lbl/text: rejoin[civil either lesser? alarm 12:00 [" AM"][" PM"]tab tab alarm]        
                alm/effect: reduce ['draw tic-toc alarm]  
                show [lbl alm]
            ]
            return
            label 60 "Minutes:"
            slider 120x16 gray blue with[data: alarm/2 / 60]
            [civil/2: alarm/2: minimum 59 to integer! value * 60
                lbl/text: rejoin[civil either lesser? alarm 12:00 [" AM"][" PM"]tab tab alarm]
                alm/effect: reduce ['draw tic-toc alarm]
                show [lbl alm]
            ]
            return
            label 60 "Seconds:"
            slider 120x16   gray yellow with[data: alarm/3 / 60]
            [civil/3: alarm/3: minimum 59 to integer! value * 60
                lbl/text: rejoin[civil either lesser? alarm 12:00 [" AM"][" PM"]tab tab alarm]
                alm/effect: reduce ['draw tic-toc alarm]
                show [lbl alm]
            ]
            return
            pad 16 btn-enter   "Set" 64 hide-popup result: alarm]
            pad 16 btn-cancel "Off" escape 64 hide-popup result: 24:00:00]
        ]
        alm: box 160x160 effect reduce ['draw tic-toc alarm]
    ]
]
    set 'request-time func "Returns a time. 0:00:00 thru 23:59:59 are set. 24:00:00 is unset"
        t [time! none!] /offset xy
    ][
        result: either t [t][24:00:00]
        the-time either t [t][now/time]
        either offset [inform/offset/title time-lay xy "what time?"] [inform/title time-lay "what time?"]
        result
    ]
]

No comments:

Post a Comment