REBOL [ file: %area-scroll-style.r title: "Area with scrollers style" author: "Didier Cadieu (alias DideC)" email: [rejoin ["didec" to-char 64 "tiscali" #"." "fr"]] date: 29-july-2004 version: 1.0.0 purpose: { This is a new area style with possible vertical and/or horizontal scrollers. It allow selection of text outside the viewable area and have a read-only mode. } comment: { Scroller(s) fully follows text scrolling and face resizing if any. Now, you can select text with mouse also if it's outside the area : it scrolls. Possible read-only mode to act like an 'info style, but with better event handling. Note : except the management of scroller part, the feel/engage func could replace the one in ctx-text. So all input style would allow selection outside the area. This style is intended to be used with Beta release of View 1.3 (1.2.16 - 1.2.47) because it uses the 'access object that was introduce in view1.2.16. There is a "compatibility" part that define the needed functions to allow the use in older version. } Copyright: {GNU Less General Public License (LGPL) - Copyright (C) Didier Cadieu 2004} license: { http://www.gnu.org/copyleft/lesser.html 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 for more details. } usage: { Use same VID specs than an 'area style with this facets more : area-scroll [vscroll] [hscroll] [scroller-width integer!] [read-only] vscroll = add a vertical scroller in the rigth of the area. hscroll = add an horizontal scroller in the bottom of the area. No effect if area is wrapped. scroller-width = followed by an integer! value, fixes the width of the scroller(s). outer-edge = put the edge arround the scrollers instead of just the area. read-only = disabled editing of the text. You can still move cursor, select and copy text, but you can't modify the text. Read-only can be enabled/disabled after layout time by adding or removing 'read-only flag to the face. } history: [ 1.0.0 29-07-2004 {first (real) public release.} ] library: [ level: 'advanced platform: 'all type: [module function] domain: [ui vid] tested-under: "View 1.2.8 and 1.2.46 WinXP" license: 'lgpl support: "email or altme" ] ] ; *** The following allow to use the style in older versions that do not contains access object if all [system/version/1 = 1 system/version/2 = 2 system/version/3 < 16] [ if not find svv/vid-styles 'scroller [ alert "Sorry, area-scroll needs 'scroller style not available in this Rebol/View version !" quit ] ctx-access: context [ field: context [ clear-face*: func [face][ if face/para [face/para/scroll: 0x0] if string? face/text [clear face/text] face/line-list: none ] get-face*: func [face][face/text] reset-face*: func [face][ if face/para [face/para/scroll: 0x0] face/text: copy "" face/line-list: none ] set-face*: func [face value][ if face/para [face/para/scroll: 0x0] face/text: form value face/line-list: none ] ] data-number: context [ clear-face*: func [face][face/data: 0] get-face*: func [face][face/data] reset-face*: func [face][face/data: 0] set-face*: func [face value][ if not number? value [ make error! reform [face/style "must be set to a number"] ] face/data: value ] ] ] stylize/master [ area: area with [ access: ctx-access/field ] scroller: scroller with [ access: ctx-access/data-number ] ] edge-size?: func [ {Return total size of face edge (both sides), even if missing edge.} face [object!] ][ either face/edge [face/edge/size * 2] [0x0] ] ] ; end of compatibility part with post 1.2.8 but pre 1.2.16 versions ; *** This function is the counterpart of scroll-para fix-slider-para: func [ {move a slider according text field scrolling.} tf {text face} sf {slider/scroller face} /redrag {also redrag the slider/scroller} /local tmp a st is ; a=axis, is=inner size, st=size of text ] [ if none? tf/para [exit] is: tf/size - edge-size? tf tmp: min 1x1 is - tf/para/margin - tf/para/origin - st: size-text tf ; Here we choose the axis. Can be done by comparing size or picking the axis in scroller ;a: either sf/size/x > sf/size/y [1][2] a: sf/axis sf/data: max 0 min 1 tf/para/scroll/:a / tmp/:a if redrag [sf/redrag min 1 is/:a / max 1 st/:a] show sf ] area-style: stylize [ area-scroll: area with [ ar: vscroll: hscroll: slf: none scroll-width: 16 ; default scroller width ; *** New words to specify wanted scrollers, scroller width and read only. words: append any [words copy []] [ vscroll [new/vscroll: true args] hscroll [new/hscroll: true args] scroller-width [if integer? args/2 [new/scroll-width: args/2] next args] read-only [flag-face new read-only args] outer-edge [flag-face new outer-edge args] ] ;*** Accessors interface: call the subface one and fix the slider access: make access [ set-face*: func [face value][ face: face/ar face/access/set-face* face value face/feel/adjust-sliders face ] get-face*: func [face][face/ar/text] clear-face*: func [face][ face: face/ar face/access/clear-face* face face/feel/adjust-sliders face ] reset-face*: func [face][ face: face/ar face/access/reset-face* face face/feel/adjust-sliders face ] resize-face*: func[face size][ face/size: size size: face/size - (2 * any [all [face/edge face/edge/size] 0x0]) if face/vscroll [ face/vscroll/offset/x: size/x: size/x - face/scroll-width ] if face/hscroll [ face/hscroll/offset/y: size/y: size/y - face/scroll-width ] face/ar/size: size if face/vscroll [face/vscroll/resize/y size/y] if face/hscroll [face/hscroll/resize/x size/x] face/ar/feel/adjust-sliders face/ar ] ] append init [ slf: self pane: copy [] if para/wrap? [hscroll: none] ; no horiz. scroller if word wrap enable ; third color for read-only mode if all [block? colors 2 = length? colors] [append colors 180.180.180] ; copy flags to avoid that View do it later flag-face self flags ;*** Create the sub-face area append pane ar: make-face/spec/size 'area [ related: copy [] ; to store the scrollers face ; *** Take parent-face facets text: slf/text data: slf/data line-list: slf/line-list para: slf/para edge: either flag-face? slf outer-edge [none][slf/edge] font: slf/font colors: slf/colors ; area style always set new flags (see facets), we don't want that append init [flags: slf/flags slf/para: para] ; *** Modify area feel to move/redrag the scroller when editing. ; *** Also add scrolling of text while selecting until outside the area. feel: make ctx-text/edit bind [ ; bitset of unallowed key while in read-only mode. read-only-filter: union copy ctx-text/keys-to-insert charset "^H^-^~^M^X^V^T" ;*** Manage area color according focus state and read-only mode redraw: func [face act pos][ if all [in face 'colors block? face/colors] [ face/color: either all [ flag-face? face read-only 3 <= length? face/colors ] [ pick face/colors pick [1 3] face <> system/view/focal-face ] [ pick face/colors face <> system/view/focal-face ] ] ] engage: func [face act event /local mov val] [ switch act [ down [ either not-equal? face view*/focal-face [ focus face view*/caret: offset-to-caret face event/offset ] [ view*/highlight-start: view*/highlight-end: none view*/caret: offset-to-caret face event/offset ] face/rate: none show face ] over [ if not-equal? view*/caret offset-to-caret face event/offset [ if not view*/highlight-start [view*/highlight-start: view*/caret] view*/highlight-end: view*/caret: offset-to-caret face event/offset face/rate: none show face ] ] away [ ; handle scrolling of area while selecting text. face/rate: 4 mov: min event/offset max 0x0 event/offset - face/size val: face/size - face/para/margin - face/para/origin - (2 * any [all [face/edge face/edge/size] 0x0]) face/para/scroll: min 0x0 max val - size-text face face/para/scroll - mov view*/highlight-end: view*/caret: offset-to-caret face confine event/offset face/para/margin face/para/origin face/size show face adjust-sliders face ] up [ ; stop scrolling if needed if face/rate [face/rate: none show face] ] time [ ; repeat scrolling of text while selecting text untill button is released. ; the event/offset is relative to window here (relative to face in over/away event) mov: event/offset - face/parent-face/offset mov: min mov max 0x0 mov - face/size val: face/size - face/para/margin - face/para/origin - (2 * any [all [face/edge face/edge/size] 0x0]) face/para/scroll: min 0x0 max val - size-text face face/para/scroll - mov view*/highlight-end: view*/caret: offset-to-caret face confine event/offset - face/parent-face/offset face/para/margin face/para/origin face/size show face adjust-sliders face ] key [ ; filter keys if in read-only mode if not all [flag-face? face read-only char? event/key find read-only-filter event/key] [ edit-text face event get in face 'action adjust-sliders face ] ] ] ] ;*** This is called from many place: ;*** just make the scrollers following the carret adjust-sliders: func [face] [ if block? face/related [ foreach tmp face/related [fix-slider-para/redrag face tmp] ] ] ] in ctx-text 'self ] max 0x0 size - to-pair reduce [ either vscroll [scroll-width][0] either hscroll [scroll-width][0] ] font: color: colors: none if not flag-face? self outer-edge [edge: none] use [make-scroller sta] [ sta: size-text ar ; *** Utility function to create scrollers make-scroller: func [siz idx /tmp s][ s: make-face/size/spec 'scroller siz [ related: ar action: func [face value][scroll-para face/related face] ] append pane s append ar/related s s ] ;*** Create vertical scroller if vscroll [ vscroll: make-scroller as-pair scroll-width ar/size/y 2 ] ;*** Create horzontal scroller if hscroll [ hscroll: make-scroller as-pair ar/size/x scroll-width 1 ] if empty? ar/related [ar/related: none] access/resize-face* self size ] ] ] ] ;************ DEMO *************** tx: {1. Introduction to VID With REBOL/View it's easy and quick to create your own user interfaces. The purpose of this tutorial is to teach you the basic concepts or REBOL/View interfaces in about 20 minutes. VID is REBOL's Visual Interface Dialect. A dialect is an extension of the REBOL language that makes it easier to express or describe information, actions, or interfaces. VID is a dialect that provides a powerful method of describing user interfaces. VID is simple to learn and provides a smooth learning curve from basic user interfaces to sophisticated distributed computing applications. 1.1. Creating VID Interfaces VID interfaces are written in plain text. You can use any text editor to create and edit your VID script. Save your script as a text file, and run it with REBOL/View. } ; *** Demo lay: none show-result: does [ if lay [unview/only lay] lay: append copy compose [ styles area-style across space 5x5 origin 5x5 (either value? 'set-face [[]][[vh3 "You will have more options with view1.2.16+" return]]) a: ] load rejoin ["[" f-final/text "]"] append lay compose [tx 450x150 return check (f-read/data) [ either value [flag-face a read-only][deflag-face a read-only] show a ] text "Read-only" (either value? 'set-face [[ btn "set-face" [set-face a "New!"] btn "get-face" [probe get-face a] btn "reset-face" [reset-face a] btn "clear-face" [clear-face a] rotary data ["450x150" "400x75" "200x75" "200x150"] [resize-face a to-pair face/text show a/parent-face] ]] [[]] ) ] view/new center-face lay: layout lay ] update-all: has [t] [ append clear t: f-basic/text "area-scroll " if f-vscroll/data [append t "vscroll "] if f-hscroll/data [append t "hscroll "] if f-swidth/data [append t join "scroller-width " [f-width/text " "]] if f-outer/data [append t "outer-edge "] if f-read/data [append t "read-only "] append clear f-final/text join f-basic/text f-facets/text show [f-basic f-final] ] view layout [ styles area-style style toggle toggle 197 [update-all] across space 5x5 origin 5x5 backcolor rebolor vh3 "Demo - area-scroll style" return vtext "Select the facets you want:" return f-vscroll: toggle true "without vertical scroller" "width vertical scroller" f-hscroll: toggle true "without horizontal scroller" "width horizontal scroller" return f-swidth: toggle "default scroller width" "my scroller witdh" vtext "width:" f-width: field 50 "10" [ face/text: to-string any [attempt [to-integer face/text] 0] update-all ] return f-outer: toggle "edge is arround the area only" "edge is arround the scrollers too" f-read: toggle false "editable" "not editable" return vtext "Basic facets:" return f-basic: info 400 return vtext "Your facets:" return f-facets: field 400 [update-all] return vtext "Full VID specification:" return f-final: info 400x50 return button "Show the result" [show-result] do [update-all] ]