REBOL [ Title: "Improved VID Field" Short: "Improved VID Field" Author: ["Henrik Mikael Kristensen"] Copyright: "2007 - HMK Design" Filename: %vid-field.r Version: 0.0.5 Created: 23-Mar-2007 Date: 01-Sep-2007 License: { BSD (www.opensource.org/licenses/bsd-license.php) Use at your own risk. } Purpose: {} History: [] Keywords: [] ] stylize/master [ field: FIELD WITH [ backspacing: numeric: numeric-keys: key-action: strict: false back-face: next-face: key-range: range: none max-length: -1 ctrl-keys: make bitset! [#"^H" #"^M" #"^~" #"^-" #" "] manip-keys: func [act event] [ any [ find [#"+" #"-"] event/key find [scroll-line scroll-page] act ] ] allowed-keys: func [key] [ any [ none? self/key-range not char? key all [ bitset? self/key-range char? key not-equal? make bitset! [] intersect make bitset! key union ctrl-keys self/key-range ] ] ] step: func [step-size [integer!] /local number] [ if self/numeric [ number: add get-face self step-size if number = to-integer number [number: to-integer number] set-face self either self/good-range? [ self/restrict-numeric-range number ][ number ] hilight-all self ] ] words: compose [ hide (func [new args][new/data: copy "" flag-face new hide args]) numeric ( func [new args][ new/numeric: true ; will the key-range be affected by numeric-keys? new/key-range: make bitset! [#"0" - #"9" #"." #","] new/ctrl-keys: difference new/ctrl-keys make bitset! [#" "] args ] ) numeric-keys ( func [new args][ new/numeric-keys: true args ] ) range (func [new args][new/range: reduce second args args: next args]) key-range ( func [new args][ new/key-range: make bitset! second args args: next args ] ) key-action ( func [new args][new/key-action: second args args: next args] ) max-length ( func [new args][new/max-length: second args args: next args] ) strict (func [new args][new/strict: true args]) back-face (func [new args][new/back-face: second args args: next args]) next-face (func [new args][new/next-face: second args args: next args]) ] good-range?: does [ all [ self/range block? self/range 2 = length? self/range number? first self/range number? second self/range ] ] in-range?: func [number] [ all [ number >= first minimum-of self/range number <= first maximum-of self/range ] ] restrict-numeric-range: func [number] [ max min number first maximum-of self/range first minimum-of self/range ] feel: make feel [ redraw: func [face act pos] bind [ if all [in face 'colors block? face/colors] [ face/color: pick face/colors face <> focal-face ] ] system/view detect: none over: none engage: func [ face act event /local tmp swap-text ] bind bind [ switch act [ down [ either equal? face focal-face [unlight-text] [focus/no-show face] caret: offset-to-caret face event/offset show face ] over [ if not-equal? caret offset-to-caret face event/offset [ unless highlight-start [highlight-start: caret] highlight-end: caret: offset-to-caret face event/offset show face ] ] scroll-line [face/step pick [1 -1] negative? event/offset/y] scroll-page [face/step pick [10 -10] negative? event/offset/y] key [ switch/default event/key [ #"^-" [ if face/numeric [ set-face face either face/good-range? [ face/restrict-numeric-range get-face face ][ get-face face ] ] tmp: either event/shift [ either face/back-face [ get face/back-face ][ back-field face ] ][ either face/next-face [ get face/next-face ][ next-field face ] ] if swap-text [ if flag-face? face hide swap-text ] if not event/shift [do in face 'action face face/data] focus tmp ] ; ---------- These two keys should not be managed when not numeric #"+" [ either all [face/numeric-keys face/numeric] [ face/step pick [10 1] event/control ; move the caret to the first position so it doesn't obstruct the number ][ edit-text face event get in face 'action ] ] #"-" [ either all [face/numeric-keys face/numeric] [ face/step pick [-10 -1] event/control ; move the caret to the first position so it doesn't obstruct the number ][ edit-text face event get in face 'action ] ] ] [ all [ face/allowed-keys event/key any [ face/max-length = -1 face/max-length <> length? get-face face not char? event/key parse/all to string! event/key [face/ctrl-keys] hilight? ] edit-text face event get in face 'action ] ] ] ] all [ any [ 'key = event/type find [scroll-line scroll-page] act ] block? face/key-action ; ---------- Don't do key-action on shift tabbing not event/shift do bind bind face/key-action 'face 'event ] ] system/view ctx-text ] ; fixes to make hide properly working. now returns face/data instead of face/text. access/get-face*: func [face] [ either face/numeric [ ; return 0 if the number is badly formatted or if the field is empty. either empty? face/data [ 0 ][ either error? try [to-decimal face/data] [ 0 ][ ; only use decimal when necessary either equal? to-integer face/data to-decimal face/data [ to-integer face/data ][ to-decimal face/data ] ] ] ][ face/data ] ] access/set-face*: func [face value][ if face/para [face/para/scroll: 0x0] ; not sure if this is the best method, but we're doing it now. ; this will nicely filter decimal values face/data: form value face/text: either flag-face? face hide [ head insert/dup copy "" "*" length? face/data ][ face/data ] face/line-list: none ] init: [ if color [colors: reduce [color colors/2]] if flag-face? self hide [ text: head insert/dup copy "" "*" length? data ] if not string? text [text: either text [form text][copy ""]] text: form either numeric [ either all [ range good-range? any [empty? text not in-range? to-integer text] ] [ form first minimum-of range ][ 0 ] ][ text ] ; hide trouble if not flag-face? self hide [data: text] ] ] name-field: FIELD WITH [ key-action: [ change head face/text form head any [ foreach word parse trim/head face/text none [ insert tail [] uppercase/part word 1 ] copy [] ] ] ] ]