REBOL [ Title: "request-font" Date: 21-Dec-2002 Name: request-font Version: 0.1.2 File: %request-font.r Home: http://to-be-added-when-no-longer-homeless/ Author: "Carl Read" Rights: "Public Domain" Needs: [REBOL/View 1.2.1] Tabs: 4 Purpose: "A font-requester for REBOL/View.^/" History: [ 0.0.0 [28-Sep-2002 "First alpha version."] 0.0.1 [6-Oct-2002 "Half-finished alpha version."] 0.0.2 [12-Oct-2002 "Finished alpha version."] 0.1.0 [19-Oct-2002 "First beta version."] 0.1.1 [11-Dec-2002 {Fixed "focus-on-font" bug.}] 0.1.2 [12-Dec-2002 {Fixed "return-to-default-font" bug.}] ] Language: English Email: carl@cybercraft.co.nz Category: [view vid util] Charset: ANSI Note: { 1) This script should be placed in the same directory as the get-fonts-[OS-type].r script. Ideally, it should be run when REBOL/View is first launched, such as from the user.r script. 2) For this script to work, it needs to find a file called fonts-data.txt in the directory it is run from. fonts-data.txt is created by running the get-fonts-[OS-type].r script. (See that script's Notes for how and when to run it.) 3) When run, this script creates a block of objects containing font data and a function called request-font which provides a font-requester for View. Those who wish to modify or write a new request-font function should ensure the "Load Fonts Data" code at the start of the script is included in their script. (That's assuming they're wishing to replace the request-font.r script with their own. An alternative request-font function created after this script has been run wouldn't need to do this.) 5) A description of the request-font refinements for those wanting to write a better requester... /title title-line Change the default title. The default is "Select a Font:". /name font-name Changes the default font name. Can be a string or block of strings. The default is the font-sans-serif string. If a block of strings are supplied they'll all be shown as picked in the text-list and the multi refinement will be set to true. /style font-style This both gives the user the option of editing the font style as well as allowing the script to set the style. The style can be none, 'bold, italic or 'underline, or, if a block is supplied, any mix of [bold italic underline]. none is the default style. /size font-size Changes the default font size. The default is 12. If none is supplied then the option for the user to edit the size isn't provided on the requester. /color font-color This both gives the user the option of editing the font color as well as allowing the script to set the color. The default color is black - 0.0.0. /font font-obj Allows the script to supply a font object. The font object supplied doesn't need to include all the font settings. This for instance... make object! [size: 24 style: [bold italic]] will just change the size and style of the default font object. This offers a way to set the settings without giving the user a means to edit them, as the individual refinements do. /effects A REBOL font-object can have the following extra settings: offset, space, align, valign, shadow and colors. The effects refinement adds options to the requester to edit all of these. /keep This keeps the settings and results from the previous use of requester. Note that the other refinements will override this, allowing you for instance to keep all the previous setting except for size if that's the behaviour you want. /multi Allow more than one font-name to be selected. This will result in a block of names being returned in the font object instead of a string. } ] ; Load Fonts Data ;================= if not value? 'fonts [fonts: []] if error? try [ insert clear fonts reduce load %fonts-data.txt ][ print "Error loading fonts data while running %request-font.r." halt ] ; Ensure default fonts are included ;----------------------------------- append fonts reduce [ make object! [name: font-fixed] make object! [name: font-sans-serif] make object! [name: font-serif] ] ; Sort and remove duplicates ;---------------------------- sort/compare fonts func [a b][a/name < b/name] forall fonts [ while [all [fonts/1 <> last fonts fonts/1/name = fonts/2/name]][ remove fonts ] ] fonts: head fonts ; End of Load fonts Data ;======================== ; Create request-font Function ;============================== request-font: func [ {Requests a font-name and optional settings. Returns a font-object. If more than one font is selected the objects name will contain a block of names. With /style, /size and /color, 'keep may be given to keep the previous settings. This allows you to place the style, size and color fields in the requester without forcing them to have a specific value.} /title "Change heading on request." title-line [string!] "Title line of request." /name font-name [string! block!] "Font name. Default is font-sans-serif." /style font-style [word! block! none!] /size font-size [integer! none!] /color font-color [tuple! word!] /font font-obj [object!] "Supply a font object." /text string [string!] "Supply example text." /effects {Allow editing of offset, space, align, valign, shadow and colors.} /keep "Keep previous settings and results." /multi "Allow more than one font name to be selected." /local settings fon refs set-style show-font get-color names icon-image lo req-list fn str blk rgb bold italic underline pos s1 s2 hi result find-font ][ ; A block to keep settings in between function calls ;---------------------------------------------------- settings: [] ; Initialize font and refinement objects or ; get them from settings if keep was set. either any [empty? settings not keep][ fon: make object! [ name: copy font-sans-serif style: none size: 12 color: 0.0.0 offset: 2x2 space: 0x0 align: 'left valign: 'top shadow: none colors: [0.0.0 255.180.55] ] refs: make object! [ title: copy "Select a Font:" str: copy "The quick brown fox jumped over the lazy dogs." name: style: size: color: effects: multi: false font-size: 12 ] ][ fon: make settings/1 [] refs: make settings/2 [] ] ; Change fon and refs values based on refinements ;------------------------------------------------- if font-obj [fon: make fon font-obj] either any [block? font-name multi][ multi: refs/multi: true if string? font-name [font-name: reduce [font-name]] if string? fon/name [fon/name: reduce [fon/name]] ][ multi: refs/multi ] either name [fon/name: font-name refs/name: true][name: refs/name] either style [fon/style: font-style refs/style: true][style: refs/style] either size [ if font-size [fon/size: font-size] refs/size: true refs/font-size: font-size ][ size: refs/size font-size: refs/font-size ] either color [ fon/colors/1: fon/color: font-color refs/color: true ][ color: refs/color ] if title [refs/title: title-line] either effects [refs/effects: true][effects: refs/effects] either string [refs/str: string][string: refs/str] ; Some functions ;---------------- set-style: does [ clear str/font/style if bold/state [append str/font/style 'bold] if italic/state [append str/font/style 'italic] if underline/state [append str/font/style 'underline] show str ] show-font: func [blk][ insert clear req-list/picked intersect blk names if not multi [remove/part req-list/picked -1 + length? req-list/picked] insert clear fn/text form req-list/picked str/font/name: last join reduce [font-sans-serif] req-list/picked show [req-list fn str] ] get-color: func [str /local color][ color: to-block trim str if error? try [ color: to-tuple either word? last :color [ first reduce head change [none] to-get-word last :color ][ last :color ] ][ color: none ] color ] ; Setup names list for text-list ;-------------------------------- names: clear [] foreach font fonts [append names font/name] ; Build layout ;-------------- icon-image: to-image layout [ backdrop black origin 1x1 space 1x1 across box 4x16 effect [gradient 0x1 255.0.0 0.0.0] box 4x16 effect [gradient 0x1 0.255.0 0.0.0] box 4x16 effect [gradient 0x1 0.0.255 0.0.0] ] if none? fon/shadow [fon/shadow: 0x0] lo: copy [ origin 10x10 style req-color button 24 effect [ gradient 0x1 66.120.192 44.80.132 draw [image icon-image 2x2] ] style lab1 h4 60 right white shadow 1x1 style lab2 lab1 50 vh2 refs/title across space 2x4 lab1 "Fonts:" req-list: text-list data names ( either system/view/screen-face/size/y < 600 [410x80][410x200] ) [ unfocus show-font copy/deep req-list/picked ] return lab1 "Font:" fn: field 410 [ either find names trim fn/text [ show-font parse/all fn/text " " ][ if not empty? fn/text [ unfocus request/ok rejoin[{Font: "} fn/text {"could not be found.}] ] fn/text: copy str/font/name show fn ] ] return lab1 "Text:" str: field 410x60 refs/str font [style: copy []] feel [ over: func [face action event][ if all [effects face/font face/font/colors] [ face/font/color: pick face/font/colors not action show face face/font/color: first face/font/colors ] ] ][refs/str: str/text] return ] blk: copy [] if not all [size not font-size][append blk [ lab2 "Size:" field 40 form fon/size [ error? try [str/font/size: to-integer face/text] face/text: form refs/font-size: str/font/size show [face str] ] ]] if any [color effects][append blk [ lab2 "Color:" rgb: field 80 form fon/color [ if rgb/text: get-color rgb/text [ str/font/colors/1: str/font/color: rgb/text ] rgb/text: form str/font/color show [rgb str] ] req-color [ if rgb/text: request-color/color str/font/color [ str/font/colors/1: str/font/color: rgb/text ] rgb/text: form str/font/color show [rgb str] ] ]] if style [append blk [ lab2 "Style:" bold: toggle "B" 24 font [style: 'bold][set-style] italic: toggle "I" 24 font [style: 'italic][set-style] underline: toggle "U" 24 font [style: 'underline][set-style] ]] if not empty? blk [ append lo [ lab1 "Options:" pos: at box 410x38 edge [ size: 2x2 color: 110.120.130 effect: 'bevel ] at pos + 8x8 ] append lo blk append lo 'return ] if effects [append lo [ lab1 "Effects:" pos: at box 410x68 edge [ size: 2x2 color: 110.120.130 effect: 'bevel ] at pos + 8x8 lab2 "Offset:" field form fon/offset 40 [ error? try [face/text: to-pair face/text] if face/text [str/font/offset: face/text] face/text: form str/font/offset show [face str] ] lab2 "Align:" s1: rotary "Left" "Center" "Right" 80 [ str/font/align: to-word face/text show str ] lab1 "VAlign:" s2: rotary "Top" "Middle" "bottom" 80 [ str/font/valign: to-word face/text show str ] at pos + 8x36 lab2 "Space:" field form fon/space 40 [ error? try [face/text: to-pair face/text] if face/text [str/font/space: face/text] face/text: form str/font/space show [face str] ] lab1 "Shadow:" field form fon/shadow 40 [ error? try [face/text: to-pair face/text] if face/text [str/font/shadow: face/text] face/text: form str/font/shadow show [face str] ] lab1 "Hilight:" hi: field form fon/colors/2 80 [ if hi/text: get-color hi/text [ str/font/colors/2: hi/text ] hi/text: form str/font/colors/2 show [hi str] ] req-color [ if hi/text: request-color/color str/font/colors/2 [ str/font/colors/2: hi/text ] hi/text: form str/font/colors/2 show [hi str] ] return ]] append lo [ button "Select" [ unview/only lo result: str/font if result/shadow = 0x0 [result/shadow: none] if 1 = length? result/style [result/style: result/style/1] if all [block? result/style empty? result/style][ result/style: none ] if multi [result/name: copy/deep req-list/picked] insert clear settings reduce [result refs] ] pad 270 button "Cancel" [unview/only lo result: none] ] lo: layout lo str/font: make fon [style: copy []] if fon/style [append str/font/style fon/style] if style [ if find str/font/style 'bold [bold/state: true] if find str/font/style 'italic [italic/state: true] if find str/font/style 'underline [underline/state: true] ] str/para: make str/para [] either effects [ str/para/wrap?: true s1/data: find s1/data form fon/align s2/data: find s2/data form fon/valign ][ str/font/valign: 'middle ] append req-list/picked fon/name show-font copy/deep req-list/picked ; Open requester ;---------------- view/title center-face lo "Request Font" result ] ; End of Create request-font Function ;=====================================