REBOL [ Title: "Text Markup Dialect Style" Date: 31-Dec-2006 Name: "TMD Style" Version: 0.8 File: %tmd-style.r Home: http://www.ladyreb.org/wiki Author: "Marco (Coccinelle) + shadwolf + Carl Sassenrath" Owner: "Coccinelle" Rights: "Public Domain" ] ; ; conversion du texte brute en TDM ; script-color-ctx: context [ ; contient les fonctions pour convertir le texte ascii brute en instructions AGG colors: [ char! 0.120.40 date! 0.120.150 decimal! 0.120.150 email! 0.120.40 file! 0.120.40 integer! 0.120.150 issue! 0.120.40 money! 0.120.150 pair! 0.120.150 string! 0.120.40 tag! 0.120.40 time! 0.120.150 tuple! 0.120.150 url! 0.120.40 refinement! 160.120.40 cmt 10.10.160 ] out: none emit: func [data] [repend out data] to-color: func [tuple][ result: copy "#" repeat n 3 [append result back back tail to-hex pick tuple n] result ] emit-color: func [value start stop /local color][ either none? :value [color: select colors 'cmt][ if path? :value [value: first :value] color: either word? :value [ any [ all [value? :value any-function? get :value 140.0.0] all [value? :value datatype? get :value 120.60.100] ] ][ any [select colors type?/word :value] ] ] either color [ ; (Done this way so script can color itself.) emit [ color copy/part start stop ] ][ emit copy/part start stop ] ] ; fonction globalisée pour être appellée depuis l'exterrieur set 'color-code func [ "Return color source code as HTML." text [string!] "Source code text" /local str new value ][ ;out: make string! 3 * length? text out: copy [] set [value text] load/next/header detab text emit copy/part head text text spc: charset [#"^(1)" - #" "] ; treat like space parse/all text blk-rule: [ some [ str: some spc new: (emit copy/part str new) | newline (emit newline)| #";" [thru newline | to end] new: (emit-color none str new) | [#"[" | #"("] (emit to-string first str) blk-rule | [#"]" | #")"] (emit to-string first str) break | skip ( set [value new] load/next str emit-color :value str new ) :new ] ] ;probe out ; pour dbg facilement le contenu généré par color-code ; mise a jour de data de tmd-area et on lance area. t/data: copy out t/init show t ] ] ; ; Area custom qui affiche le format TDM ; tmd-ctx: context [ ; début du code TDM line-info: make system/view/line-info [] item-face: make face [ offset: 0x0 size: 0x0 edge: make face/edge [] font: make face/font [] para: make face/para [] feel: make face/feel [] ] wrk-face: make face [ offset: 0x0 size: 0x0 edge: make face/edge [] font: make face/font [] para: make face/para [] feel: make face/feel [] ] key-to-insert: make bitset! #{ 01000000FFFFFFFFFFFFFFFFFFFFFF7FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF } key-to-map: [ #"^H" back-char #"^-" tab-char #"^~" del-char #"^M" enter #"^A" all-text #"^C" copy-text #"^X" cut-text #"^V" paste-text #"^T" clear-tail ] ; ********************************************************** ; Parse the Text Markup Dialect and palce each piece of text ; ********************************************************** tmd-render: func [ face [object!] /local text stack info list row rule i current s w ][ if equal? face/checksum face/checksum: checksum remold [ ; indexe pour la recherche des faces filles dans la liste des face face/data face/size face/edge face/font face/para ][ return false ] ; Initialize the local values stack: copy [] face/list: copy [] append row: copy [] current: context [ offset: face/para/origin * 0x1 size: 0x0 font-size: 0 ] wrk-face/size: item-face/size: face/size - (2 * face/edge/size) - face/para/origin - face/para/margin wrk-face/edge: item-face/edge: make face/edge [ effect: none size: 0x0 ] wrk-face/para: item-face/para: make face/para [ origin: 0x0 margin: 0x0 indent: 0x0 ] wrk-face/font: item-face/font: make face/font [ offset: 0x0 space: 0x0 align: 'left valign: 'top ] ; ----------------------------------- ; Parse the Text Markup Dialect block ; and set the horizontal position ;------------------------------------ parse face/data rule: [( insert stack item-face/font item-face/font: make item-face/font [] ) any [ into rule | s: set text string! ( ; Initialize item to current text item-face/text: text item-face/para/indent/x: current/size/x item-face/line-list: none ; Repeat for each line in the item (if the text is splitted into many lines) i: 0 while [ ; Get the line info textinfo item-face line-info i ][ ; If it's not the first line in the item if positive? i [ ; Adjust the horizontal offset of the line current/offset/x: face/para/origin/x + switch face/font/align [ left [0] center [(item-face/size/x - current/size/x) / 2] right [item-face/size/x - current/size/x] ] ; Create a new line and set the vertical offset append row current: context [ offset: (current/offset + current/size) * 0x1 size: 0x0 font-size: 0 ] ] ; Calculates the item size wrk-face/text: copy/part line-info/start line-info/num-chars wrk-face/para: make item-face/para [indent/x: line-info/offset/x] wrk-face/font: item-face/font current/size/x: first caret-to-offset wrk-face tail wrk-face/text current/size/y: max current/size/y line-info/size/y current/font-size: max current/font-size wrk-face/font/size ; Append the item to the item list append face/list context [ ; data: s start: line-info/start num-chars: line-info/num-chars offset: line-info/offset ; size: current/size - line-info/offset size: line-info/size font: item-face/font line: current ] ; Loop foreach line in the item i: i + 1 ] item-face/font: make stack/1 [] ) | ; Style words [ set text 'bold | set text 'italic | set text 'underline] ( item-face/font/style: union any [item-face/font/style copy []] reduce [text] ) | ; Font words [set text 'font-serif | set text 'font-sans-serif | set text 'font-fixed] (item-face/font/name: text) | 'font [ set text string! (item-face/font/name: text) | set text block! (item-face/font: make item-face/font text) ] | set text integer! (item-face/font/size: text) | set text tuple! (item-face/font/color: text) | set text word! ( switch type?/word text: get text [ integer! [item-face/font/size: text] tuple! [item-face/font/color: text] ] ) | skip ]( remove stack item-face/font: stack/1 )] ; --------------------------------------------- ; Adjust the horizontal offset of the last line ; --------------------------------------------- current/offset/x: face/para/origin/x + switch face/font/align [ left [0] center [(item-face/size/x - current/size/x) / 2] right [item-face/size/x - current/size/x] ] ; -------------------------------------- ; Set the vertical position of each item ; -------------------------------------- foreach info face/list [ info/offset/x: info/offset/x + info/line/offset/x info/offset/y: info/line/offset/y + info/line/font-size - info/font/size ] return true ] ; ******************************************* ; Build the draw block (called by redraw feel ; ******************************************* tmd-redraw: func [ face [object!] /local info draw highlight caret start end left center right ][ tmd-render face ; -------------------------- ; And produce the draw block ; -------------------------- draw: copy [] start: none end: none if all [ system/view/highlight-start system/view/highlight-end start: make tmd-offset-and-caret face system/view/highlight-start [] end: make tmd-offset-and-caret face system/view/highlight-end [] ][ if any [ start/offset/y > end/offset/y all [ start/offset/y = end/offset/y start/offset/x > end/offset/x ] ][ highlight: start start: end end: highlight ] start/offset/y: start/info/line/offset/y end/offset/y: end/info/line/offset/y + end/info/line/size/y ] highlight: off foreach info face/list [ text-start: info/start offset-start: info/offset text-end: at info/start info/num-chars offset-end: info/offset + (info/size/x * 1x0) ; ---------------------------------------------- ; Draw the first part in case of highlight start ; ---------------------------------------------- left: copy [] if all [ start end same? start/info/start info/start ][ if not same? text-start start/caret [ left: compose [ pen (info/font/color) text (copy/part text-start subtract index? start/caret index? text-start) (offset-start) aliased ] offset-start/x: start/offset/x text-start: start/caret ] highlight: on ] ; ------------------------------------------ ; Draw the end part in case of highlight end ; ------------------------------------------ right: copy [] if all [ start end same? end/info/start info/start ][ if not same? text-end end/caret [ offset-end/x: end/offset/x right: compose [ pen (info/font/color) text (copy/part end/caret 1 + subtract index? text-end index? end/caret) (offset-end) aliased ] text-end: back end/caret ] ] ; ----------------------------------------------- ; Draw the middle part in case of highlight start ; ----------------------------------------------- center: copy [] center: either highlight [ compose [ pen (complement face/color) fill-pen (complement face/color) box ( 1x0 + (offset-start * 1x0) + (info/line/offset * 0x1) )( -1x0 + (offset-end/x * 1x0) + ((info/line/offset + info/line/size) * 0x1) ) pen (complement info/font/color) ] ][ compose [ pen (info/font/color) ] ] append center compose [ text (copy/part text-start 1 + subtract index? text-end index? text-start) (offset-start) aliased ] ; ------------------------ ; Reset the highlight flag ; ------------------------ if all [ start end same? end/info/start info/start ][ highlight: off ] ; ------------------------------------------------------- ; Append to the draw bloc the three piece of draw dialect ; ------------------------------------------------------- append draw compose [ font (info/font) (left) (center) (right) ] ] ; ------------------------- ; Set the face effect block ; ------------------------- face/effect: compose/only [ draw (draw) ] ; ---------------- ; Manage the caret ; ---------------- if face/caret [ face/pane/offset: (face/caret/offset * 1x0) + (face/caret/info/offset * 0x1)+ -1x1 face/pane/size: 5x0 + (face/caret/info/line/size * 0x1) face/pane/font: face/caret/info/font ] ] ; ************************************************************************** ; Calculates the caret and the offset based on the string or offset position ; ************************************************************************** tmd-offset-and-caret: func [ face [object!] "The face containing the text." offset [string! pair! object!] /local item list info result ][ if all [ tmd-render face object? offset ][ offset: offset/caret ] if object? offset [return offset] result: context [ list: none info: none caret: none offset: none ] list: face/list either string? offset [ result/caret: offset forall list [ info: first list if all [ same? head info/start head offset lesser-or-equal? index? info/start index? offset greater-or-equal? add index? info/start info/num-chars index? offset ][ result/list: list result/info: info break ] ] ][ forall list [ info: first list if within? offset (info/offset * 1x0) + (info/line/offset * 0x1) (info/size * 1x0) + (info/line/size * 0x1) [ result/list: list result/info: info break ] ] ] unless result/info [return none] wrk-face/size: result/info/line/size wrk-face/size/x: face/size/x - (2 * face/edge/size/x) - face/para/origin/x - face/para/margin/x wrk-face/text: copy/part result/info/start result/info/num-chars wrk-face/edge/effect: none wrk-face/edge/size: 0x0 wrk-face/para: make face/para [ origin: 0x0 margin: 0x0 indent/x: 0 indent/y: result/info/offset/y - result/info/line/offset/y ] wrk-face/line-list: none wrk-face/font: result/info/font if pair? offset [ result/caret: offset-to-caret wrk-face to pair! reduce [ offset/x - result/info/offset/x wrk-face/para/indent/y ] unless result/caret [return none] result/caret: at result/info/start index? result/caret ] result/offset: caret-to-offset wrk-face at wrk-face/text 1 + subtract index? result/caret index? result/info/start unless result/caret [return none] result/offset: to pair! reduce [ result/info/offset/x + result/offset/x result/info/line/offset/y ] result ] ; ************************************************* ; Calculates the offset based on the caret position ; ************************************************* tmd-to-offset: func [ {Returns the offset position relative to the face of the character position.} face [object!] "The face containing the text." offset [any-string!] "The offset in the text." /local item info ][ if result: tmd-offset-and-caret face offset [ result/offset ] ] ; ************************************************* ; Calculates the caret based on the offset position ; ************************************************* tmd-to-caret: func [ {Returns the offset in the face's text corresponding to the offset pair.} face [object!] "The face containing the text." offset [pair!] "The XY offset relative to the face." /local result ][ if result: tmd-offset-and-caret face offset [ result/caret ] ] ; ************************************************* ; Move to caret ; ************************************************* move-to-caret: func [ face [object!] "The face containing the text." offset [string! pair! object!] ][ system/view/highlight-start: system/view/highlight-end: none face/caret: tmd-offset-and-caret face offset show face ] ; ************************************************* ; Highlight to caret ; ************************************************* highlight-to-caret: func [ face [object!] "The face containing the text." offset [string! pair! object!] /local wrk-caret ][ if wrk-caret: tmd-offset-and-caret face offset [ unless face/caret [face/caret: wrk-caret] unless system/view/highlight-start [system/view/highlight-start: face/caret] system/view/highlight-end: face/caret: wrk-caret if same? system/view/highlight-start/caret system/view/highlight-end/caret [ system/view/highlight-start: system/view/highlight-end: none ] ] show face ] ; ************************ ; Build the tmd-area style ; ************************ stylize/master [ tmd-area: area feel [ redraw: func [face act pos][ if act = 'draw [ if all [in face 'colors block? face/colors][ face/color: pick face/colors face/pane <> system/view/focal-face ] tmd-redraw face ] ] engage: func [ face act event /local wrk-caret ][ switch act [ down [ ; the main mouse button was pressed. unless same? face/pane system/view/focal-face [ focus/no-show face/pane ] move-to-caret face event/offset ] over [ ; the mouse was moved over the face while the button was pressed. highlight-to-caret face event/offset ] key [ key: event/key if char? key [ if all [ find key-to-insert key face/caret ][ unlight-text face/caret: tmd-offset-and-caret face insert face/caret/caret key show face exit ] unless key: select key-to-map key [ exit ] ] switch key [ left [ if all [ not head? face/caret/list head? face/caret/caret ][ face/caret/list: back face/caret/list face/caret/info: first face/caret/list face/caret/caret: tail face/caret/info/start ] if not head? face/caret/caret [ either event/shift [ highlight-to-caret face back face/caret/caret ][ move-to-caret face back face/caret/caret ] exit ] ] right [ if all [ not tail? next face/caret/list tail? face/caret/caret ][ face/caret/list: next face/caret/list face/caret/info: first face/caret/list face/caret/caret: head face/caret/info/start ] if not tail? face/caret/caret [ either event/shift [ highlight-to-caret face next face/caret/caret ][ move-to-caret face next face/caret/caret ] exit ] ] ] ; probe key ] ] ] ] para [ wrap?: true ] font [ valign: 'bottom ] with [ words: reduce [ 'data func [new args][args] ] me: does [self] init: [ data: select facets 'data pane: make face compose/deep [ offset: 0x0 size: 0x0 color: none text: "" edge: none para: make face/para [ origin: 0x0 margin: 0x0 offset: 0x0 ] flags: none dirty?: none feel: make face/feel [ redraw: func [face act pos][ ; Propagate the redraw event if the face lose the focus face: me if all [ in face 'colors block? face/colors not-equal? face/color face/color: pick face/colors face/pane <> system/view/focal-face ] [ show face ] ] over: none detect: none engage: func [face act event][ ; Propagate the engage event face: me face/feel/engage face act event ] ] ] ] data: none caret: none list: none checksum: none ] ] ] ; open file function and start the text to TDM parsing open-file: func [ /local file ] [ file: request-file if file [ color-code read first file ] ] ; ***************** ; Basic test window ; ***************** print "" view layout/size [ across btn "Open file" [ open-file ] return s: rotary "400x520" "300x520" "200x520" "100x520" [t/size: to-pair get-face s show t unfocus] a: rotary "left" "center" "right" [t/font/align: to-word get-face a show t unfocus ] return t: tmd-area 400x520 para [origin: 10x10 margin: 10x10] data [] ; data [ ; "This is an example of ^j REBOL markup text." ; " Here the word " bold "bold" " is bolded. " ; bold "This entire sentence is bold." ; font [size: 28 name: 'font-sans-serif][" This is " bold italic 24 "bold and italic" ". "] ; "This text is " blue "blue in color" ". " ; "This text is " 200.80.40 "redish in color" ". " ; underline ["This is an " 24 "example of text " ; bold ["that " 18 "is bold " blue ["blue and " 48 ["REALLY BIG"]]] ". "] ; "And now it's normal text" ;] ] 440x600