REBOL [
	Title: "REBOL Word Browser (Dictionary)"
	Author: "Carl Sassenrath"
	Version: 2.1.1
	history: [
		2.0.1 12-Sep-2005 "Carl" {First release on the web}
		2.1.0 16-Sep-2005 "Didier Cadieu" {Resizing and mouse wheel handling.}
		2.1.1 17-Sep-2005 "Gregg Irwin" {Minor UI tweaks - top bar height, func summary/bkgnd color}
	]
]

if lesser? system/version 1.3.1 [alert "Requires View 1.3.1 or better" quit]

*word-marker: none

;-- Provide proxy functions for words that would cause GUI problems:

*isolator: context [

	view: func
		first get in system/words 'view
		head insert copy/deep second get in system/words 'view [new: true]

]

*word-browser: context [

site-url: http://www.rebol.com/docs/
dict-file: %word-defs.r
cmts-file: %word-cmts.r
cats-file: %word-cats.r

temp-files: [] ;%word-defs-new-carl.r %word-defs-new-gregg.r]
end-cats: [not-found internal]
word-stack: []
this-word: word-stack
ref: []
cats-list: none


;-- GUI for scrollable function description area:

body-style: code-style: link-style: xy: none
out-lay: [] ; build word layout here

style-layout: layout [
	body-style: txt
	link-style: txt bold font [
		colors: reduce [maroon red]
		color: first colors
		style: [underline bold]
	][
		face/font/color: first face/font/colors ; patch
		show-word face/user-data
	]
	code-style: tt bold black 220.220.220
		font [colors: reduce [black blue]]
		para [origin: 2x8 margin: 2x8]
		edge [size: 1x1 color: gray + 40]
		[attempt [do bind load face/text *isolator]]
	head-style: h3 400x25 bottom 16.48.160
	cmt-btn: btn-enter "Add Comment" [add-comment]
]

; Patch for better text-list resizing / Didier
svv/vid-styles/text-list/resize: func [new /x /y /local tmp] bind [
	either any [x y] [
		if x [size/x: new] 
		if y [size/y: new]
	] [
		size: any [new size]
	] 
	pane/size: sz: size 
	sld/offset/x: first sub-area/size: size - 16x0 
	sld/resize/y: size/y 
	iter/size/x: first sub-area/size - sub-area/edge/size 
	lc: to-integer sz/y / iter/size/y
	sld/redrag lc / max 1 length? data
	;*** Here is the changes : recompute the list position and resync dragger bar
	sn: max 0 min sn tmp: 1 - lc + length? data
	sld/data: sn / max 1 tmp
	self
] svv/vid-styles/text-list

reset-layout: does [
	clear out-lay
	xy: 16x0
]

make-text: func [
	"Make a section of text"
	str style indent /link
	/local face word
][
	if link [word: str str: form str]
	face: make-face style
	face/text: str
	face/line-list: none
	;face/color: yellow
	face/size: f-info/size - (indent * 1x0) - xy/x      ; in sync for resizing
	face/size/y: face/para/origin/y + face/para/margin/y + second size-text face 
	if link [face/user-data: :word  face/size/x: 4 + first size-text face]
	face/offset: indent * 1x0 + xy
	xy/y: xy/y + face/size/y
	if not link [xy: xy + 0x6]
	append out-lay face
]

make-arg: func [
	"Create an argument entry in function arg table"
	arg-word arg-info type-info
	/local pane sz szp
][
	szp: as-pair min 520 f-info/size/x - xy/x  34   ;size of full arg box
	sz: as-pair min 440 szp/x - 82  -1              ;size of description lines

	pane: layout [
		size szp
		style txt txt font-size 11 para [origin: margin: 2x1]
		origin 0 space 0

		;-- Argument word:
		txt mold arg-word 80x34 bold black
			either refinement? arg-word [sky][240.240.180]
			center middle 

		;-- Argument description:
		at 80x0
		txt sz bold black snow middle
			either arg-info [form arg-info][
				reform ["The" arg-word pick ["refinement." "argument."] refinement? arg-word]
		]

		;-- Argument datatype:
		txt sz black 200.220.200 middle
			either refinement? arg-word ["A refinement."][
				join "Accepts: " either type-info [reform type-info]["anything"]
		]
		sz: at
	]
	pane/size/y: 2 + pane/pane/1/size/y: sz/y   ; resize verticaly if wrap has occured
	
	pane/edge: make pane/edge [size: 1x1 color: gray + 40]
	pane/color: snow
	pane/offset: xy
	xy/y: xy/y + pane/size/y - 2 ; edge height
	append out-lay pane
]

make-heading: func [title] [
	append-face make head-style [text: title]
]

pad-space: func [y] [xy/y: xy/y + y]

append-face: func [face] [
	face/offset/y: xy/y
	face/offset/x: 0
	xy/y: xy/y + face/size/y + 6 ;12
	append out-lay face
]

make-body-text: func [str] [make-text str body-style 0]
make-code-text: func [str] [make-text str code-style 2]
make-link: func [word] [make-text/link word link-style 10]

show-info: func [title summary text] [
	f-name/text: title
	f-args/text: none
	f-summary/text: summary
	f-name/size/x: 400
	reset-layout
	replace/all text "^/^/" "~"
	text: parse/all text "~"
	foreach txt text [
		make-body-text trim/lines txt
	]
	show main
]

;-- Function description parser:

code: text: none
space: charset " ^-"
chars: complement charset " ^-^/"
rules: [some parts]
parts: [
	  newline
	| example
	| paragraph
]
example: [
	copy text some [indented | some newline indented]
	(make-code-text trim/tail text)
]
paragraph: [copy text some [chars thru newline] (make-body-text trim/lines text)]
indented:  [some space thru newline]

spec-parser: context [
	data: f-cmt: f-atr: a-word: a-types: a-cmt: a-ref: a-ref-cmt: f: h: none
	fun-cmt: [set val string! (f-cmt: val)]
	fun-atr: [set val block!  (f-atr: val)]
	fun-intro: [(f-cmt: f-atr: none) fun-cmt opt fun-atr | fun-atr opt fun-cmt | none (f-cmt: "")]
	arg-word: [
		set a-word [
			word! (f: :to-word)
			| get-word! (f: :to-get-word)
			| lit-word! (f: :to-lit-word)
		]
		(a-word: f a-word)
	]
	arg-types: [set a-types block!]
	arg-cmt: [set a-cmt string!] 
	fun-arg: [
		(a-types: a-cmt: none)
		arg-word opt arg-types opt arg-cmt
		(repend data [a-word a-cmt a-types])
	]
	ref-word: [set a-ref refinement! h: (if a-ref = /local [h: tail h]) :h]
	ref-cmt: [set a-ref-cmt string!]
	fun-spec: [
		opt [fun-intro (repend data [f-cmt f-atr])]
		any fun-arg
		any [ (a-ref-cmt: none)
			ref-word
			opt ref-cmt (if a-ref <> /local [a-ref-cmt repend data [a-ref a-ref-cmt none]])
			any fun-arg
		]
	]
	set 'parse-spec func [word] [
		data: reduce [word]
		parse third get word fun-spec
		data  ; word comment attr  some [arg-word comment type]
	]
]

;-- Word list builder:

words: []
search-text: none

filter-words: func [
	type
	/list wrds
	/local new-words
][
	if not list [show-category type]
	case [
		type = first end-cats [words: missing-words]
		type = 'all [words: extract ref 2]
		list [words: wrds]
		true [
			clear words
			foreach [word def] ref [
				if all [block? def/1 find def/1 type] [append words word]
			]
		]
	]
	if value? 'f-funcs [
		f-funcs/texts: f-funcs/lines: f-funcs/data: words
		f-funcs/sn: f-funcs/sld/data: 0
		f-funcs/sld/redrag f-funcs/lc / max 1 length? words
		show f-funcs
	]
]

missing-words: has [
	"Return list of words that are missing from dictionary."
	words sys-words sys-vals
][
	words: make block! 40
	sys-words: first system/words
	sys-words: copy/part sys-words back find sys-words '*word-marker
	sys-vals: second system/words
	foreach word sys-words [
		if all [
			not find ref word
			any-function? first sys-vals
		][append words word]
		sys-vals: next sys-vals
	]
	bind sort words 'system
]

search-words: func [text /local words tmp got] [
	unselect-lists
	words: clear []
	foreach [word def] ref [
		if find tmp: form word text [
			if tmp = text [got: word]
			append words word
		]
	]
	filter-words/list none words
	got
]

;-- The Main Window GUI:

h: none
wh: 0x500 ; height of description area
bh: wh + 0x46 ; height of lists
words: []
types: []

f-word: b-bk: b-fd: f-cats: f-funcs: f-name: f-args: f-summary: f-info: f-slid: f-bar: f-tools: none

main: layout [
	origin 0 space 0x0
	backcolor snow - 10

	style bbar text white 20x24 40.40.80 bold middle

	;-- Top Bar for Subjects and Buttons:
	across
	lab 50 "Find:" black gold effect compose [gradient 0x1 gold (gold - 50)]
	f-word: field 180 "" edge [size: 1x1] middle
	h: at
	b-bk: box 20x24 40.40.80 effect [draw [line-width .01 fill-pen gold triangle 5x10 17x3 17x17] grayscale] [back-ref-word]
	b-fd: box 20x24 40.40.80 effect [draw [line-width .01 fill-pen gold triangle 3x3 3x17 15x10] grayscale] [next-ref-word]
	f-bar: bbar 552x24 - 40x0 - 100x0
	f-tools: panel [
		space 0x0 across
		bbar "*" [launch/quit system/options/script]
		bbar 40x24 "Print" [alert "Not available yet."]
		bbar 40x24 "Prefs" [alert "Not available yet."]
	]
	return
	bbar 100x20 "Categories" 
	pad 1x0
	bbar 130x20 - 1x0 "Words" 
	pad 1x0
	return

	;-- Category and Word Lists:
	f-cats:  text-list bold 16.48.160 100x0 + bh data types [filter-words value]
	f-funcs: text-list bold 130x0 + bh data words [show-word value] return
	return

	;-- Function Details:
	at h + 6x26 guide
	f-name: h1 400x28 160.0.0
	pad 0x2
	f-args: h2 italic 36x24 bottom return
	pad 2x0
	f-summary: txt 100.100.100 bold 500 "a^/a" as-is return
	f-info: box 524x0 + wh snow ;edge [size: 1x1 color: silver]

	;-- Scroll bar:
	at f-info/offset + (f-info/size * 1x0) + 6x0
	f-slid: scroller 16x0 + wh [
		scroll-box/offset/y: negate value * (scroll-box/size/y - f-info/size/y) show f-info
	]
	do [f-slid/redrag 1]
	return

	key keycode [up]   [pick-back] 
	key keycode [down] [pick-next] 
	key keycode [left] [back-ref-word] 
	key keycode [right] [next-ref-word] 
	key keycode escape [quit] 
]

;-- Main window event handling (resize and mouse wheel scroll)
; store needed values here
main/user-data: reduce ['size main/size 'mouse 0x0]

main/feel: make main/feel [
	detect: func [face event /local tl nb] [
		switch event/type [
			key [   ; handle the standard window feel for 'key event
				if face: find-key-face face event/key [
					if get in face 'action [do-face face event/key]
					event: none
				]
			]

			; mouse position must be stored somewhere for 'scroll-line event
			move [face/user-data/mouse: event/offset]
			
			scroll-line [
				if within? face/user-data/mouse f-cats/offset f-cats/size [tl: f-cats]
				if within? face/user-data/mouse f-funcs/offset f-funcs/size [tl: f-funcs]
				all [tl  scroll-text-list tl event/offset/y  event: none]
				if f-cats/size/x + f-funcs/size/x < face/user-data/mouse/x [
					nb: scroll-box/offset/y - (event/offset/y * 20)
					scroll-box/offset/y: nb: min 0 max nb f-info/size/y - scroll-box/size/y
					f-slid/data: nb / min -1 f-info/size/y - scroll-box/size/y
					show [f-info f-slid]
					event: none
				]
			]
			
			resize [
				nb: face/size - face/user-data/size     ; compute size difference
				face/user-data/size: face/size          ; store new size
				f-bar/size/x: f-bar/size/x + nb/x
				f-tools/offset/x: f-tools/offset/x + nb/x
				f-cats/resize/y f-cats/size/y + nb/y
				f-funcs/resize/y f-funcs/size/y + nb/y
				f-name/size/x: f-summary/size/x: f-summary/size/x + nb/x
				f-info/pane/size/x: first f-info/size: f-info/size + nb
				f-slid/resize/y f-slid/size/y + nb/y
				f-slid/offset/x: f-slid/offset/x + nb/x
				f-slid/redrag f-info/size/y / scroll-box/size/y
				either this-word/1 [show-word this-word/1][show main]
				event: none
			]
		]
		event
	]
]

scroll-text-list: func [
	{scroll a text-list by some lines}
	tl lines /local tmp
] [
	tmp: 1 - tl/lc + length? tl/data
	tl/sn: max 0 min tmp lines + tl/sn
	tl/sld/data: max 0.0 min 1.0 tl/sn / tmp
	show tl
]

scroll-box: make-face f-info
f-info/pane: scroll-box
scroll-box/edge: none
scroll-box/offset: 0x0
scroll-box/pane: out-lay
focus f-word

f-word/feel: make f-word/feel [
	; Used for the incremental FIND field:
	redraw: func [face act pos][
		face/color: pick face/colors face <> system/view/focal-face
		if all [
			face = system/view/focal-face
			face/text <> search-text
		][
			search-text: copy face/text
			if any [
				value: search-words face/text
				1 = length? words
			][
				show-word any [value words/1]
			]
		]
	]
]

gray-arrow: func [face cond] [
	; Make back/fwd arrows gray:
	remove find face/effect 'grayscale
	if cond [insert tail face/effect [grayscale]]
]

unselect-lists: does [
	clear f-cats/picked
	clear f-funcs/picked
	show [f-cats f-funcs]
]

show-category: func [type /local cat] [
	cat: select cats-list type
	if any [not cat tail? cat] [cat: ["No summary." ""]]
	if tail next cat [append cat ""]
	show-info uppercase/part form type 1 cat/1 cat/2
]

pick-next: has [f] [
	f: all [f-funcs/picked f-funcs/picked/1]
	either none? f [f-funcs/picked: reduce [f-funcs/data/1]][
		f: find f-funcs/data f
		if tail? next f [exit]
		f-funcs/picked: reduce [first f: next f]
	]
	sync-funcs-list index? f
	show-word first f-funcs/picked
	show f-funcs
]

pick-back: has [f] [
	f: all [f-funcs/picked f-funcs/picked/1]
	either none? f [f-funcs/picked: reduce [f-funcs/data/1]][
		f: find f-funcs/data f
		f-funcs/picked: reduce [first f: back f]
	]
	sync-funcs-list index? f
	show-word first f-funcs/picked
	show f-funcs
]

sync-funcs-list: func [
	{scroll the functions list if the selected word is out of the viewed area}
	pos
] [
	f-funcs/sn: min f-funcs/sn pos - 1
	f-funcs/sn: max f-funcs/sn pos - f-funcs/lc
	f-funcs/sld/data: f-funcs/sn / (1 - f-funcs/lc + length? f-funcs/data)  
]

;-- Dictionary word description GUI:
 
show-word: func [word /local attr also desc cmts lst args type] [
	if none? word [exit]

	if word <> this-word/1 [
		insert this-word: tail this-word word
	]

	gray-arrow b-bk head? this-word
	gray-arrow b-fd tail? next this-word

	set [attr also desc cmts] select ref word

	;-- Generate list of args (without refinements):
	either all [
		value? word
		any-function? get word
	][
		lst: parse-spec word
		args: copy []
		foreach [word a b] skip lst 3 [
			if refinement? word [break]
			append args word
		]
	][
		args: []
		type: type? either value? word [get word][word]
		lst: reduce ["" reform ["Datatype:" type]]
	]
	;-- Set word, arguments, and summary:
	f-name/text: form word
	f-args/text: trim/lines mold/only args
	f-args/offset/x: f-name/offset/x + 4 + first size-text f-name
	f-args/size/x: 300
	f-summary/text: trim/lines lst/2

	;-- Reset layout:
	reset-layout

	;-- Argument section:
	if not tail? skip lst 3 [
		make-heading "Arguments:"
		foreach [word cmt type] skip lst 3 [make-arg word cmt type]
		pad-space 8
	]

	;-- Description section:
	make-heading "Description:"
	either desc [parse/all detab desc rules][
		make-body-text "No description provided. To be added."
	]

	if also [
		make-heading "See Also:"
		sort also
		foreach word also [make-link word]
	]

	;-- Comment section:
	if any [cmts select ref-cmts word] [
		make-heading "User Comments:"
		if cmts [
			parse/all detab cmts rules
		]
		if cmts: select ref-cmts word [
			parse/all detab cmts rules
		]
	]
	pad-space 8
	append-face cmt-btn

	;-- Reset scroll bar:
	scroll-box/size/y: xy/y
	f-slid/data: 0.0
	f-slid/redrag f-info/size/y / max 1 scroll-box/size/y
	f-info/pane/offset/y: 0
	show main
]

back-ref-word: does [
	unselect-lists
	this-word: back this-word
	show-word this-word/1
]

next-ref-word: does [
	unselect-lists
	this-word: next this-word
	if tail? this-word [this-word: back this-word]
	show-word this-word/1
]

;-- Post comment (needs revision):

cmt-lay: none

add-comment: has [] [
	alert "Not available yet" exit
	if none? cmt-lay [
		cmt-lay: layout [
			;styles link-styles backdrop
			h2 300
			new-cmt: area "" 400x300 wrap
			across
			button "Save" [
				hide-popup
				repend new-cmt/text [newline newline]
				either "ok" <> post-server reduce ['reference this-word new-cmt/text][
					request/ok "Unable to access server. Posting failed."
				][
					entry: select ref-cmts this-word
					insert new-cmt/text reduce ["^/^/-From: " user-prefs/name " [pending]^/^/"]
					either entry [append entry new-cmt/text entry][repend ref-cmts [this-word new-cmt/text]]
				]
				show-word this-word
			]
			button "Cancel" [hide-popup]
		]
	]
	cmt-lay/pane/2/text: reform ["Add comments to:" this-word]
	clear new-cmt/text
	new-cmt/line-list: none
	focus new-cmt
	inform cmt-lay
]

;-- Load data files:

reload: func [file] [
	; Load and decompress a file:
	if not exists? file [
		all [
			data: request-download site-url/:file
			data: attempt [decompress data]
			attempt [write/binary file data]
		]
	]
	if not data: attempt [load file] [
		alert reform ["Problem loading file:" file " - cannot continue."]
		quit
	]
	data
]

load-files: has [cats] [

	if not all [
		exists? dict-file
		exists? cats-file
	][
		if not confirm {The REBOL dictionary datafiles must be downloaded
			for you to continue. Download them now?} [
			quit
		]
	]

	ref: reload dict-file
	cats-list: reload cats-file

	ref-cmts: either exists? cmts-file [load cmts-file][copy []]
	foreach f temp-files [append ref load f]

	cats: []
	foreach [word desc] ref [
		if select ref-cmts word [
			if not find desc/1 #commented [append desc/1 #commented]
		]
		if block? desc/1 [append cats desc/1]
	]
	cats: unique cats
	sort cats
	remove find cats 'internal
	insert cats 'all
	append cats end-cats
	insert clear f-cats/data cats
	show main
]

;-- Bring it up:

show-info "REBOL Word Browser" 
"An interactive dictionary for REBOL." {
Type a word into the search field for a quick lookup.

Or, click on the category, then select a word to see information about it.

The not-found category finds words that have not yet been documented in the
dictionary.

Click examples to evaluate them.

Arrow keys move between entries and backward/forward.

The internal category lists words that are internal to REBOL.

We will add the user comment method, printing, prefs and more.
}

view/new/options center-face main [resize min-size 600x400]
load-files
make-dir %temp-examples/
change-dir %temp-examples/

do-events

]