REBOL [
	Title: "Parse Analysis Toolset /View"
	Date: 25-May-2013
	File: %parse-analysis-view.r
	Purpose: "Some REBOL/View tools to help learn/analyse parse rules."
	Version: 2.1.0
	Author: "Brett Handley"
	Web: http://www.codeconscious.com
	Needs: [
		%parse-analysis.r ; rebol.org
		%rebol-text-parser.r ; rebol.org
	]
	Library: [
		level: 'advanced
		platform: 'all
		type: [tool function]
		domain: [parse text-processing debug]
		tested-under: [
			view 2.7.8.3.1 on [Win7] {Basic tests.} "Brett"
		]
		support: none
		license: 'apache-v2.0
		see-also: [%load-parse-tree.r] ; And see NEEDS block above.
	]
	License: {

		Copyright 2013 Brett Handley

		Licensed under the Apache License, Version 2.0 (the "License");
		you may not use this file except in compliance with the License.
		You may obtain a copy of the License at

			http://www.apache.org/licenses/LICENSE-2.0

		Unless required by applicable law or agreed to in writing, software
		distributed under the License is distributed on an "AS IS" BASIS,
		WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
		See the License for the specific language governing permissions and
		limitations under the License.
	}
	History: [
		2.1.0 [25-May-2013 "Add Resizing to make-token-stepper. Add rebol-text-parser.r to needs block. Couple of tweeks to scrolling." "Brett Handley"]
		2.0.0 [4-Mar-2013 "Release as version 2. Licensed with Apache License, Version 2.0" "Brett Handley"]
		1.3.0 [24-Feb-2013 {Accommodate major changes to parse-analysis.r} "Brett Handley"]
		1.2.3 [23-Feb-2013 {Bugfix and make highlighter style highlight drawing more robust, multiple other enhancements.} "Brett Handley"]
		1.2.2 [22-Feb-2013 {Added show-lf keyword to highlighter style, multiple other enhancements.} "Brett Handley"]
		1.2.1 [18-Feb-2013 {Added mouse-wheel scrolling and other navigation.} "Brett Handley"]
		1.2.0 [13-Feb-2013 {Changed some variable handling. Major new addition: make-token-stepper.
			Added comments. Added visualise-parse.} "Brett Handley"]
		1.1.0 [19-Dec-2004 "First published version." "Brett Handley"]
		1.0.0 [19-Dec-2004 "Initial version." "Brett Handley"]
	]
]

script-manager do-needs ; Does each file listed in NEEDS block.

; -----------------------------------------------------------------------------------
;
; Comments
;
;	This script helps visualise the matching of parse rules against text.
;	It currently only works with string! type inputs because I haven't
;	worked out yet how to do caret-to-offset functionality with block inputs.
;
;	I don't claim it to be a model of good design, it has been evolved until it does what
;	I want it to do. In addition it was created originally with a slider style
;	and I've just introduced scroller. I'm pretty sure there are better ways
;	to organise the interactions but I'm too rusty with VID to do it right now.
;
;	I hope this will encourage people to develop and share useful REBOL parse rules,
;	protocols and applications.
;
;
; MAKE-TOKEN-STEPPER
;
;
; Purpose:
;
;	Step through and highlight where rules match the input so as to be able
;	to follow what happened during a parse run and help identify problems in parse rules.
;
;
; Concept/behaviour:
;
;	A parsing run is traced into a sequence of parse steps (events). Make-token-stepper
;	allows you to move forward and backward through the steps.
;
;	Each step is one of three types:
;
;		TEST - When a parse rule is invoked to start testing the input.
;		PASS - When a parse rule has successfully matched some input.
;		FAIL - When a parse rule has completed unsuccessfully.
;
;	Moving forward through the steps, at each TEST the rule is added to the Active stack
;	and is highlighted in orange. At each PASS or FAIL it is removed from the Active stack
;	and highlighted in Green if it passed or Red if it failed.
;
;	The status area shows the current step number, the step details and the Active rule stack.
;	The structure of a step is [EVENT rulename length-matched input-position]
;
;	At all times the current rule definition is shown at the very bottom of the window.
;
;	Line feed characters (newline) are indicated by a small white block at the end of lines.
;
;
; Navigating with keys and mouse:
;
;	The basics:
;
;		Normal mouse highlight/copy is available, it is unreleated to the other functions.
;
;		Mouse scroll wheel - scroll the page.
;
;		page-down, page-up - scroll by page.
;
;		down - next parse step
;		up - prior parse step
;
;		ctrl home - move to first parse step
;		ctrl end - move to last parse step
;
;		ctrl page-down - scroll so end of rule is visible without changing highlights.
;		ctrl page-up - scroll so start of rule is visible without changing highlights.
;
;
;	Finding the longest match of input.
;
;		ctrl shift home = move to the first step that got furthest through the input.
;		ctrl shift end = move to the last step that got furthest through the input.
;
;			Note: These last two are worth trying first when your rules are not working,
;			      because they have a good chance of showing where the problem occurs.
;
;
;	When the input position is important:
;
;		Ctrl + mouse click - moves to parse step that matched that position in the input.
;
;		end / home = next/previous PASS at this position. Input position is held constant, so you
;		             can "zoom out" to parent rules with the End key and "zoom in" to child rules
;                        at the same position with the Home key.
;
;	When the rules are more important:
;
;		White Rule buttons (rules that passed sometime) = move to the next PASS for that rule.
;		Gray Rule buttons (rules that never passed) = move to the next FAIL for that rule.
;
;		right / left = next/previous PASS of any rule (hold shift for FAIL).
;
;		ctrl right / ctrl left = next/previous time this rule will PASS (hold shift for FAIL).
;
;		ctrl down = Move to the step that this rule finishes with a PASS or FAIL.
;		ctrl up = Move to the step that this rule started with a TEST.
;
;
; MAKE-TOKEN-HIGHLIGHTER
;
; Purpose:
;
;	Creates a face that shows token names in a scroll panel and
;	text input in the main part. Clicking on a token name highlights
;	all parts of the text that are matched by that token.
;
; Notes:
;
;	Each token is considered to be a different colour. By using the
;	token name as the colour and passing that to the HIGHTLIGHTED-TEXT
;	style all text with that token (colour) can be highlighted at once.
;
;	Superseeded by MAKE-TOKEN-STEPPER.
;
;
;
; VISUALISE-PARSE
;
; Purpose:
;
;	An easy way to use make-token-stepper.
;
; -----------------------------------------------------------------------------------



stylize/master [

	;
	; Highlighted-Text Style
	;
	;	Set HIGHLIGHTS with a block of [colour length caret] triples.
	;	Use HIGHLIGHT to calculate the draw effect for the highlights.
	;


	HIGHLIGHTED-TEXT: text with [
		highlights: show-lf: sizing-face: sizing-adj: line-leading: none
		text-size?: func[text][
			insert clear sizing-face/text text
			sizing-adj + size-text sizing-face
		]
		highlight: has [
			text.xy text.start text.end line.tail line.tail.xy visual.end box.extent tmp tmp.xy
			drw-blk nl
		] [
			line-leading: 0x1 * text-size? {M}
			append clear drw-blk: effect/draw [pen white]
			if any [not highlights empty? highlights] [return]
			foreach [caret length colour] head reverse copy highlights [
				text.start: at text caret
				text.end: skip text.start length

				; Highlight may cover multple lines, draw each.
				while [
					all [
						length > 0 ; Prevent drawing empty highlights.
						(index? text.start) < (index? text.end)
					]
				] [
					; Need to find the character tail for this highlight.
					; There could be a line break due to wrap, or newline, before text.end.
					; If offset x is > start, then character is on the same line (a newline).

					text.xy: caret-to-offset self text.start
					visual.end: offset-to-caret self to pair! reduce [size/1 text.xy/2]
					tmp: at text max (index? text.start) min (index? visual.end) (subtract index? text.end 1) ; Search optimisation.

					until [
						tmp: next tmp
						tmp.xy: caret-to-offset self tmp
						any [
							(tail? tmp)
							(tmp.xy/x <= text.xy/x)
							(index? tmp) >= (index? text.end)
						]
					]
					line.tail: tmp

					; line.tail is at the tail of the line, or tail of the highlight.
					; Visually, it could be on the same line, or on the following line (newline/wrap).
					; But we want the offset of the end of the current line.
					nl: none
					line.tail.xy: caret-to-offset self line.tail

					if line.tail.xy/2 > text.xy/2 [
						line.tail.xy: either nl: newline = first back line.tail [
							(either show-lf [10x0][0x0]) + (caret-to-offset self back line.tail)
						][
							(caret-to-offset self back line.tail) + (text-size? first back line.tail)
						]
					]

					; Now draw line highlight.
					box.extent: subtract line.tail.xy text.xy
					box.extent/2: line-leading/2
					if edge [text.xy: text.xy - edge/size] ; Draw is relative to edge.
					if edge [line.tail.xy: line.tail.xy - edge/size] ; Draw is relative to edge.
					insert tail drw-blk reduce ['fill-pen colour 'box text.xy text.xy + box.extent]
					if nl [
						line.tail.xy: line.tail.xy - 8x1 + line-leading - 0x7
						if show-lf [insert tail drw-blk reduce ['fill-pen show-lf 'box line.tail.xy line.tail.xy + 4x5]]
					]
					if text.start = line.tail [
						make error! {Should not happen. Line.tail = Text.Start during draw highlights.}
					]

					text.start: line.tail
				]
			]
		]
		words: [
			highlights [new/highlights: second args next args]
			show-lf [new/show-lf: second args next args] ; Draws newlines.
		]
		append init [
			effect: append/only copy [draw] make block! multiply 5 divide length? any [highlights []] 3
			sizing-face: make-face/styles/spec 'text copy self/styles compose [size: (size)] ; Need to copy fonts.
			sizing-adj: 0x0
			sizing-adj: -1x0 * subtract (2 * text-size? {X}) (text-size? {XX})
			if all [show-lf not tuple? :show-lf] [show-lf: gray]
			if show-lf [size: size + 10x0] ; Space for line feed indicator.
			highlight
		]
	]

	SCROLL-PANEL: FACE edge [size: 2x2 effect: 'ibevel] with [

		data-padding: data: cropbox: sliders: none

		; returns unit-vector for an axis
		uv?: func [w] [either w = 'x [1x0] [0x1]]

		; calculates canvas size
		sz?: func [f] [either f/edge [f/size - (2 * f/edge/size)] [f/size]]

		; calculates size of data not shown.
		hiddenamt?: func [] [max 0x0 data/size - (sz? cropbox)]

		; slider widths for both directions as a pair
		sldw: 15x15

		; Manages the pane.
		layout-pane: function [/resize child-face] [sz dsz v v1 v2 lyo] [
			if none? data [data: copy []]

			; Convert VID to a face.
			if block? data [data: layout/offset/styles data 0x0 copy self/styles]

			; On initial layout create the crop-box and sliders.
			if not resize [
				if not size [size: data/size if edge [size: 2 * edge/size + size]]
				lyo: layout compose/deep [
					origin 0x0 cropbox: box
					scroller 5x1 * sldw [
						face/parent-face/scroll-to-match face
					]
					scroller 1x5 * sldw [
						face/parent-face/scroll-to-match face
					]
				]
				sliders: copy/part next lyo/pane 2
				pane: lyo/pane
			]

			; data face goes inside cropbox
			cropbox/pane: data
			sz: sz? self
			cropbox/size: sz dsz: data/size

			; Determine the size of the content plus any required sliders.
			repeat i 2 [
				repeat v [x y] [
					if dsz/:v > sz/:v [dsz: sldw * (reverse uv? v) + dsz]
				]
			]
			dsz: min dsz sldw + data/size

			; Size the cropbox to accomodate sliders.
			repeat v [x y] [
				if (dsz/:v > sz/:v) [
					cropbox/size: cropbox/size - (sldw * (reverse uv? v))
				]
			]

			; Size and position the sliders - non-required slider(s) is/are off stage.
			repeat sl sliders [
				v2: reverse v1: uv? v: sl/axis
				sl/offset: cropbox/size * v2
				sl/size: add 2 * sl/edge/size + cropbox/size * v1 sldw * v2
				sl/resize none
				sl/redrag divide cropbox/size/:v data/size/:v
				if resize [svvf/drag-off sl sl/pane/1 0x0]
			]
			if resize [do-face self data/offset]
			self
		]

		; Page scrolling.
		page-down: func [] [
			scroll-drag/page sliders/2
			show face
		]

		page-up: func [] [
			scroll-drag/back/page sliders/2
			show face
		]

		; Ensure item can be seen, scroll if necessary.
		show-item: func [
			offset extent
			/surround min-surround {Minimum to show before or after the item.}
			/local tl br unseen
		] [
			if not surround [min-surround: 45x45]
			unseen: hiddenamt?
			tl: offset + cropbox/pane/offset - min-surround ; tl is relative to cropbox.
			br: tl + extent + min-surround
			foreach axis [x y][
				if tl/:axis < 0 [cropbox/pane/offset/:axis: min 0 cropbox/pane/offset/:axis + negate tl/:axis]
				if br/:axis > cropbox/size/:axis [cropbox/pane/offset/:axis: max negate unseen/:axis cropbox/pane/offset/:axis - (br/:axis - cropbox/size/:axis)]
			]
			move-scrollers/no-action/offset cropbox/pane/offset ; Sync scroller to new position.
		]

		; Set the scroller in code and fire event so page scrolls.
		move-scrollers: func [
			{Move the vertical scroller.}
			value
			/axis {Scroll only one axis.} axis-name [word!]
			/relative {Relative to current position.}
			/offset {Value is an offset, instead of a proportion.}
			/no-action {Don't fire the scroller's action (prevents scroller from scrolling the view).}
			/local dnm unseen bar-axis axis-v
		] [
			unseen: hiddenamt?
			foreach bar sliders [
				bar-axis: bar/axis
				if any [not axis :bar-axis = :axis-name][
					axis-v: value
					if offset [axis-v: either zero? dnm: unseen/:bar-axis [0] [divide negate value/:bar-axis dnm]]
					if relative [axis-v: bar/data + axis-v]
					axis-v: min 1 max 0 axis-v
					bar/data: axis-v
					if not no-action [do-face bar none]
					show bar
				]
			]
		]

		; Scrolls view to match the scroller position.
		scroll-to-match: func [
			{Scroll subpanel to match the scroller position.}
			bar
			/local uv other-axis
		] [
			uv: uv? bar/axis
			this-axis: uv * negate bar/data * hiddenamt?
			other-axis: cropbox/pane/offset * reverse uv ; Other axis component.
			cropbox/pane/offset: other-axis + this-axis
			cropbox/changes: 'offset ; Performance hint to graphics system.
			show cropbox
			do-face self cropbox/pane/offset
			self
		]

		; Method to change the content
		modify: func [spec] [data: spec layout-pane/resize self]

		; Resize method.
		resize: func [new /x /y] [
			either any [x y] [
				if x [size/x: new]
				if y [size/y: new]
			] [size: any [new size]]
			layout-pane/resize self
		]

		init: [feel: none layout-pane]

		; Keywords.
		words: [data [new/data: second args next args]
			action [new/action: func [face value] second args next args]]
		multi: make multi [
			image: file: text: none
			block: func [face blk] [if blk/1 [face/data: blk/1]]
		]
	]
]

make-token-highlighter: func [
	{Returns a face which highlights tokens.}
	input "The input the tokens are based on."
	tokens [block!] "Block of tokens as returned from the tokenise-parse function."
] [

	use [
		sz-main sz-input names name-count name-area ctx
		token-lyo colours set-highlight trace-term btns
		highlighter-face
	] [

		sz-main: divide multiply 13 subtract system/view/screen-face/size 0x150 16

		sz-input: sz-main
		ctx-text/unlight-text

		; Build colours and bind token words to them.
		name-count: length? names: unique extract tokens 3
		colours: make block! 1 + name-count
		foreach name names [insert tail colours reduce [to set-word! name silver]]
		colours: context colours
		tokens: bind/copy tokens in colours 'self

		; An object to store window specific methods.
		ctx: context [
			rule?: func [
				"Returns the rules that are satisfied at the given input position."
				tokens "As returned from tokenise-parse."
				position [integer!] "The index position to check."
				/local result
			] [
				if empty? tokens [return copy []]
				result: make block! 100
				forskip tokens 3 [
					if all [
						get in colours tokens/1 ; Make sure only highlighted terms are selected
						position >= tokens/3 tokens/3 + tokens/2 > position] [
						insert tail result copy/part tokens 3
					]
				]
				result
			]
			all-highlights: has [btn] [
				repeat word next first colours [
					set in colours word sky
					btn: get in btns word
					btn/edge/color: sky
				]
			]
			clear-highlights: has [btn] [
				repeat word next first colours [
					set in colours word none
					btn: get in btns word
					btn/edge/color: silver
				]
			]
			set-highlight: func [name /local clr btn] [
				clr: 110.110.110 + random 120.120.120
				set in colours name clr ; Set the highlighted token.
				btn: get in btns name
				btn/edge/color: clr
			]
		]

		; Build name area
		btns: make colours []
		name-area: append make block! 2 * length? names [
			origin 0x0 space 0x0 across
			btn "[Clear]" [
				ctx-text/unlight-text clear trace-term/text
				token-lyo/user-data/clear-highlights show token-lyo
			]
			btn "[All]" [
				ctx-text/unlight-text clear trace-term/text
				token-lyo/user-data/all-highlights show token-lyo
			]
		]
		foreach name names [
			insert tail name-area append reduce [
				(first bind reduce [to set-word! name] in btns 'self) 'btn
				form name get in colours name
				compose [token-lyo/user-data/set-highlight (to lit-word! name) show token-lyo]
			] [edge [size: 3x3]]
		]

		; Build main layout
		token-lyo: layout [

			origin 0x0 space 0x0

			; The names
			scroll-panel to pair! reduce [sz-input/1 45] name-area

			; The input
			scroll-panel sz-input [

				origin 0x0 space 0x0

				highlighter-face: highlighted-text black input as-is highlights tokens feel [
					engage: func [face act event /local rules pos] [
						switch act [
							down [
								either not-equal? face system/view/focal-face [
									focus face
									system/view/caret: offset-to-caret face event/offset
								] [
									system/view/highlight-start:
									system/view/highlight-end: none
									system/view/caret: offset-to-caret face event/offset
								]
								pos: index? system/view/caret ; map cursor to position in the input
								rules: token-lyo/user-data/rule? tokens pos ; get the rules at the input position
								; highlight the first (most specific) rule
								if not empty? rules [
									system/view/highlight-start: at face/text rules/3
									system/view/highlight-end: skip system/view/highlight-start rules/2
								]
								insert clear trace-term/text form head reverse extract rules 3
								show face show trace-term
							]
						]
					]
				]

			]

			; The text area at bottom.
			trace-term: area wrap to pair! reduce [sz-main/1 40]

		]
		token-lyo/user-data: ctx
		token-lyo/text: "Token Highlighter"
		token-lyo/user-data/all-highlights
		token-lyo
	]
]


make-token-stepper: func [
	{Returns a face which highlights tokens.}
	input "The input the tokens are based on."
	steps [block!] "Block of tokens as returned from the tokenise-parse function with /fails refinement."
] [

	use [
		sz-main sz-input names name-count name-area ctx
		token-lyo colours set-highlight btns
		tokens txt-height nm-height
		highlighter-face btn-scroll main-scroll trace-term rule-term resizing-delta
	] [

		rule-stack: copy []
		tokens: steps

		txt-height: 40
		nm-height: 45

		sz-main: divide multiply subtract system/view/screen-face/size (to pair! reduce [0 2 * txt-height + nm-height]) 2 3

		sz-input: subtract sz-main (to pair! reduce [0 2 * txt-height + nm-height])
		ctx-text/unlight-text

		; Build colours and bind token words to them.
		name-count: length? names: unique extract next tokens 4
		colours: make block! 1 + name-count
		foreach name names [insert tail colours to set-word! name]
		colours: context append colours 'white

		; Generate VID for name area.
		btns: make colours []
		name-area: append make block! 2 * length? names [
			origin 0x0 space 0x0 across
		]
		use [passed] [
			foreach name names [
				passed: found? find tokens reduce ['pass :name]
				insert tail name-area append reduce [
					(first bind reduce [to set-word! name] in btns 'self) 'btn
					form name
					set in colours name either passed [white] [gray]
					'with compose [data: (passed)]
					compose [
						token-lyo/user-data/move-to-step-for-rule/state/rule face/data (to lit-word! name)
						token-lyo/user-data/scroll-to-rule
						token-lyo/user-data/update-highlights/no-namescroll
					]
				] [edge [size: 3x3]]
			]
		]

		; Build main layout
		token-lyo: layout [

			origin 0x0 space 0x0

			; The names
			btn-scroll: scroll-panel to pair! reduce [sz-input/1 nm-height] name-area

			; The input
			main-scroll: scroll-panel sz-input [

				origin 0x0 space 0x0

				highlighter-face: highlighted-text black input as-is show-lf true feel [

					engage: func [face act event /local rules pos get-pos] [

						ctx-text/swipe/engage :face :act :event ; Provides for text highlight/copy.
						if face <> system/view/focal-face [focus face] ; Swipe feel may have unfocussed this face.

						get-pos: func [] [
							either not-equal? face system/view/focal-face [
								focus face
								system/view/caret: offset-to-caret face event/offset
							] [
								system/view/highlight-start:
								system/view/highlight-end: none
								system/view/caret: offset-to-caret face event/offset
							]
							index? system/view/caret ; map cursor to position in the input
						]

						switch act bind [
							up [
								if event/control [
									pos: get-pos
									move-to-position pos event/control event/shift
									update-highlights
								]
							]
							key [
								switch event/key [
									end [either event/control [either event/shift [move-to-furthest-input true] [last-step]] [next-step-at-pos event/shift] scroll-to-rule/end update-highlights]
									home [either event/control [either event/shift [move-to-furthest-input false] [first-step]] [prior-step-at-pos event/shift] scroll-to-rule update-highlights]
									down [either event/control [move-to-step-for-rule] [next-step] scroll-to-rule/end update-highlights]
									up [either event/control [move-to-step-for-rule/first] [prior-step] scroll-to-rule update-highlights]
									right [either event/control [move-to-step-for-rule/state not event/shift] [move-to-next-pass event/shift] scroll-to-rule/end update-highlights]
									left [either event/control [move-to-step-for-rule/prior/state not event/shift] [move-to-prior-pass event/shift] scroll-to-rule update-highlights]
									page-down [either event/control [scroll-to-rule/end update-highlights] [main-scroll/page-down]]
									page-up [either event/control [scroll-to-rule update-highlights] [main-scroll/page-up]]
								]
							]
							scroll-line [
								main-scroll/move-scrollers/relative/offset/axis (-1 * event/offset/y * face/line-leading) 'y
								show main-scroll
							]
						] token-lyo/user-data
					]

				]

			]

			; The text area at bottom.
			trace-term: area wrap to pair! reduce [sz-main/1 txt-height]

			; The text area at bottom.
			rule-term: area wrap to pair! reduce [sz-main/1 txt-height]

		]


		; An object to store window methods and data.
		ctx: context [
			all-highlights: has [btn] [
				repeat word next first colours [
					set in colours word sky
					btn: get in btns word
					btn/edge/color: sky
				]
			]
			clear-highlights: has [btn] [
				repeat word next first colours [
					set in colours word none
					btn: get in btns word
					btn/edge/color: silver
				]
			]
			set-highlight: func [name scroll /colour clr /local btn] [
				if not colour [clr: 110.110.110 + random 120.120.120]
				set in colours name clr ; Set the highlighted token.
				btn: get in btns name
				btn/edge/color: clr
				if scroll [btn-scroll/show-item btn/offset btn/size]
			]

			current-step: tokens
			rule-stack: copy []
			sticky-position: none

			at-end?: does [not lesser? index? current-step subtract length? tokens 4]

			init: func [] [
				token-lyo/text: "Token Stepper"
				if not tail? current-step [append rule-stack current-step/2]
				sticky-position: current-step/4
				resizing-delta: token-lyo/size - main-scroll/size
			]

			resize: func [][
				main-scroll/size: token-lyo/size - resizing-delta
				rule-term/size/x: trace-term/size/x: btn-scroll/size/x: main-scroll/size/x
				abut 0x1 reduce [btn-scroll main-scroll trace-term rule-term]
				btn-scroll/resize none
				main-scroll/resize none
			]

			update-highlights: func [/no-namescroll /local clr event rule length position] [
				if not tail? current-step [
					clear-highlights
					set [event rule length position] current-step
					clr: either 'fail = event [red] [either 'test = event [orange] [green]]
					set-highlight/colour :rule (not no-namescroll) clr
					highlighter-face/highlights: reduce [
						tan position - 1 1
						clr length position
					]
					highlighter-face/highlight
					insert clear rule-term/text mold get rule
				]
				insert clear trace-term/text reform [
					"Step:" add divide subtract index? current-step 1 4 1
					mold new-line/all copy/part current-step 4 false
					"Active:" mold rule-stack
				]
				show token-lyo
			]

			next-step: func [/sticky] [
				if at-end? [return]
				current-step: skip current-step 4
				if not at-end? [
					either 'test = current-step/1 [append rule-stack current-step/2] [remove back tail rule-stack]
				]
				if sticky [sticky-position: current-step/4]
			]
			prior-step: func [/sticky] [
				if head? current-step [return]
				if not at-end? [
					either 'test <> current-step/1 [append rule-stack current-step/2] [remove back tail rule-stack]
				]
				current-step: skip current-step -4
				if sticky [sticky-position: current-step/4]
			]

			first-step: func [] [
				current-step: head current-step
				clear rule-stack
				init
			]

			last-step: func [] [
				insert clear trace-term/text {Searching...} show trace-term
				while [not at-end?] [next-step]
				sticky-position: current-step/4
			]

			move-next-until: func [condition /nonsticky /local event rule length position result] [
				if at-end? [return false]
				until compose/deep [
					next-step
					set [event rule length position] current-step
					any [
						result: (bind :condition 'event)
						at-end?
					]
				]
				if not nonsticky [sticky-position: position]
				return result
			]
			move-prior-until: func [condition /nonsticky /local event rule length position result] [
				if head? current-step [return false]
				until compose/deep [
					prior-step
					set [event rule length position] current-step
					any [
						result: (bind :condition 'event)
						head? current-step
					]
				]
				if not nonsticky [sticky-position: position]
				return result
			]
			move-to-next-pass: func [failures /local word] [
				insert clear trace-term/text {Searching...} show trace-term
				word: either failures ['fail] ['pass]
				move-next-until [:word = :event]
			]
			move-to-prior-pass: func [failures /local word] [
				insert clear trace-term/text {Searching...} show trace-term
				word: either failures ['fail] ['pass]
				move-prior-until [:word = :event]
			]

			move-to-step-for-rule: func [/first /prior /state pass /rule name /local condition bookmark save-rules result] [
				insert clear trace-term/text {Searching...} show trace-term
				if not rule [name: current-step/2]
				bookmark: current-step save-rules: copy rule-stack
				either first [
					prior: true
					condition: ['test = :event :name = :rule]
				] [
					condition: compose either state [
						[(to lit-word! either pass ['pass] ['fail]) = :event :name = :rule]
					] [
						['test != :event :name = :rule]
					]
				]
				result: do either prior [:move-prior-until] [:move-next-until] compose/only [all (condition)]
				if not result [current-step: bookmark rule-stack: save-rules]
			]

			move-to-furthest-input: func [last? /local bookmark save-rules] [
				insert clear trace-term/text {Searching...} show trace-term
				first-step
				bookmark: current-step save-rules: copy rule-stack
				while [not at-end?] compose [
					if current-step/4 (either last? [[>=]] [[>]]) bookmark/4 [bookmark: current-step save-rules: copy rule-stack]
					next-step/sticky
				]
				current-step: bookmark rule-stack: save-rules
			]

			move-to-position: func [pos special failures] [
				insert clear trace-term/text {Searching...} show trace-term

				either failures [

					; Move forwards to find next rule that failed at or after position.
					if (current-step/4 + current-step/3 - 1) < pos [
						move-next-until [all ['fail = :event position >= pos]]
						return
					]

					; Move backwards to find rule that failed at position or before
					if current-step/4 > pos [
						move-prior-until [all ['fail = :event position < pos]]
					]

				] [

					; Move forwards to find next rule that matches position.
					if (current-step/4 + current-step/3 - 1) < pos [
						move-next-until [(position + length - 1) >= pos]
						return
					]

					; Move backwards to find rule that matches position
					if current-step/4 > pos [
						move-prior-until [position < pos]
					]

				]

			]

			next-step-at-pos: func [special /local pos word bookmark save-rules] [
				insert clear trace-term/text {Searching...} show trace-term
				word: 'pass
				pos: sticky-position
				bookmark: current-step save-rules: copy rule-stack
				move-next-until/nonsticky [all [:word = :event position <= pos (position + length - 1) >= pos]]
				if not all [current-step/4 <= pos (current-step/4 + current-step/3 - 1) >= pos] [
					current-step: bookmark rule-stack: save-rules
				]
			]

			prior-step-at-pos: func [special /local pos word bookmark save-rules] [
				insert clear trace-term/text {Searching...} show trace-term
				word: 'pass
				pos: sticky-position
				bookmark: current-step save-rules: copy rule-stack
				move-prior-until/nonsticky [all [:word = :event position <= pos (position + length - 1) >= pos]]
				if not all [current-step/4 <= pos (current-step/4 + current-step/3 - 1) >= pos] [
					current-step: bookmark rule-stack: save-rules
				]
			]

			scroll-to-rule: func [/end {Show end of rule.} /local pos offset end-offset extent] [
				pos: at highlighter-face/text current-step/4
				either end [
					pos: skip pos current-step/3 ; End of rule (new rule starts here).
					extent: 3 * highlighter-face/line-leading
				] [
					extent: 4 * highlighter-face/line-leading ; Provide a bit of surround at bottom.
				]
				offset: caret-to-offset highlighter-face pos
				main-scroll/show-item offset extent
			]

		]

		token-lyo/user-data: ctx
		focus highlighter-face
		token-lyo/user-data/init
		token-lyo/user-data/update-highlights

		; Resizing event.
		token-lyo/feel: make token-lyo/feel [
			detect: func [face event] [
				switch event/type [
					key [
						if face: find-key-face face event/key [
							if get in face 'action [do-face face event/key]
							return none
						]
					]
					resize [
						token-lyo/user-data/resize
						show face
					]
				]
				event
			]
		]

		center-face token-lyo
		token-lyo
	]
]


abut: func [
	{Make faces abut each other, in the specified direction.}
	uv {Unit vector direction. 1x0 or 0x1} [pair!]
	faces [block!]
	/local offset
] [
	offset: get in first faces 'offset
	foreach face faces [
		face/offset: offset
		offset: uv * face/size + offset
	]
]


visualise-parse: func [
	{Displays your input and highlights the parse rules.}
	data [string! block!] {Input to the parse.}
	rules [block! object!] {Block of words or an object containing rules. Each word must identify a Parse rule to be hooked.}
	body [block!] {Invoke Parse on your input.}
	/ignore {Exclude specific terms from result.} exclude-terms [block!] {Block of words representing rules.}
	/local result block tokens
][
	if not ignore [exclude-terms: copy []]
	view/new center-face layout [title "Visualise Parse" label "Tokenising input..."]
	error? set/any 'result try [
		tokens: tokenise-parse/all-events/ignore rules body exclude-terms
		if block? data [
			block: data
			data: mold block
			convert-block-to-text-tokens/text block tokens data
		]
	]
	unview
	if error? get/any 'result [
		view center-face layout [title "Visualise Parse - Error" text as-is error-text? disarm result button "Ok" [unview]]
		tokens: none
	]
	if block? tokens [
		view/options make-token-stepper data tokens [resize]
	]
]