REBOL [
	Title:  "CID Consumer Interface Dialect"
	Rights: "Copyright 1997-2000 REBOL Technologies All Rights Reserved"
	File:   %cid.r
	Date:   28-Jan-2000
	Needs:  0.9.0
]


CID-test: on
CID-verbose: off

;--- Predefined Colors:
black: 0.0.0
white: 255.255.255
red:   255.10.10
green: 10.255.10
blue:  10.10.255

;--- GUI Dialect Functions -------------------------------------

if CID-verbose [print "Make Functions"]

load-thru: func [
	"Load file thru home/public cache (temp)"
	url [url!] /local path file data
][
	set [path file] split-path url
	path: join system/options/home %public/
	if not exists? path [make-dir path]
	either exists? path/:file [
		load path/:file
	][
		data: read/binary url
		write/binary path/:file data
		load data
	]
]

CID-core: make object! [

	face-styles: reduce ['face face]

	track: func [blk] [if CID-verbose [print blk]]

	image-cache: []

	load-image: function [image-file] [image] [
		if not image: select image-cache image-file [
			append image-cache reduce [image-file image: load image-file]
		]
		image
	]

	set 'get-style func [name][select face-styles name]

	set 'stylize function [
		"Create new face styles, based on sytle dialect."
		styles [block!] "Block of style triplets: new-style from-style specs"
	] [where old-face spot] [
		foreach [new old specs] styles [
			if where: select reduce [
				word? new	 ["new face name" new]	   
				word? old	 ["existing face name" old]	 
				block? specs ["face specification block" specs]
			] false [ print ["Expected" reduce where] halt ]
	
			foreach var [body: edge: font: para:] [
				where: find/tail specs :var
				if where [insert where compose [make (to word! :var)]]
			]
			track ["New Style" new "from" old]

			if not old-face: select face-styles old [print ["no such style:" old] halt]
			either spot: find face-styles new [
				if CID-verbose [print ["Redefining style:" new]]
				change next spot make old-face specs
			][append face-styles reduce [new make old-face specs]]
		]
	]
	
	set 'layout function [
		"Layout a pane from a block of style descriptions."
		pane-size [pair!] "Size (wide and high) of pane"
		specs [block!] "Block of styles, attributes, and layouts"
	] [ pane where here new way var pair a-num hr a-var
		int-pair var-name set-pos a-face a-name a-origin 
	] [
		pane: copy []
		spacing: 10x10
		a-origin: 20x20
		where: a-origin
		way: 0x1
		error: func [msg spot] [
			print [msg either series? spot [copy/part spot 6][spot]]
		]
		pair: [
			set a-pair pair! |
			set var word! (if all [value? var pair? get var] [set a-pair get var]) |
			none (error "Expected a position or size" none)
		]
		num: [
			set a-num integer! |
			set a-num pair! |
	;		set var word! (if all [value? var any [number? get var pair? get var]] [
	;			set a-num get var]) |
			none (error "Expected an integer" none)
		]
		int-pair: [
			set a-num integer! |
			set a-num pair! |
			hr: set a-paren paren! (
				a-var: do :a-paren
				either any [integer? a-var pair? a-var][a-num: a-var hr: next hr]
				[error "Expected word position:" hr]
			) :hr |
			hr: set a-var word! (
				if value? :a-var [
					a-var: get :a-var
					either any [integer? a-var pair? a-var][a-num: a-var hr: next hr]
					[error "Expected word position:" hr]
				]
			) :hr
		]
		name: [set a-name word! | none (error "Expected a name" none)]
		var-name: none
		set-pos: [(if :var-name [set :var-name where var-name: none])]
		parse specs [
			some [
				here:  ;(probe copy/part here 3)
				set a-name set-word! (var-name: :a-name) |
				'space num (spacing: a-num) |
				'origin [set a-pair pair! (a-origin: a-pair) | none] (where: a-origin) |
				'across set-pos (way: 1x0) |
				'down set-pos (way: 0x1) |
				'mark set-pos |
				'guide set-pos int-pair (
					where/x: either integer? a-num [a-num][a-num/x]
				) |
				'indent set-pos int-pair (
					where/x: either integer? a-num [where/x + a-num][a-num/x]
				) |
				'pad set-pos int-pair (
					where: where + either integer? a-num [way * a-num][a-num]
				) |
				'at set-pos int-pair (
					where: either pair? a-num [a-num][
						way * a-num + (where * either (way = 0x1) [1x0][0x1])
					]
				) |
			;	'pane block ...
			;	'table block ...
				'with set var word! (append pane get var) |
				set a-name word! here: (
					track ["Face:" a-name]
					either a-face: select face-styles a-name [
						append pane new: make a-face [max-size: pane-size]
						if :var-name [set :var-name new var-name: none]
						while [not tail? here][
							value: first here
							if paren? :value [value: value]
							if word? :value [ ; variable attribute, get it
								either value? value [value: get value][break]
							]
							var: switch/default type?/word :value [
								string! [new/text: value]
								pair! [new/size: value append new/options 'size]
								tuple! [
									either new/body [
										new/body: make new/body [color: value]
									][
										new/font: make new/font [color: value]
									]
									append new/options 'color
								]
								image! [if new/body [
									new/body: make new/body [image: value]
								]]
								file! [if new/body [
									new/body: make new/body [image: load-image value]
								]]
								block! [new/action: value]
							][break]
							here: next here
						]
						do new/after
						if new/rules [
							r: new/rules
							parse here [r here:]
						]
						if not new/at-offset [
							new/offset: where
							where: way * (new/size + spacing) + where
						]
						if any [new/offset/x > pane-size/x new/offset/y > pane-size/y][
							error "Face offset outside the pane:" a-name
						]
					][error "Unknown style:" a-name]
				) :here | 
				here: skip (error "Layout error:" here)
			]
		]
		pane
	]

]

;--- Standard Face Feelings ------------------------------------

if CID-Verbose [print "Make Feelings"]

CID-feel: make object! [

	sensor: make face/feel [
		engage: func [face action event index][
			switch action [
				down [face/state: on]
				up [if face/state [do face/action] face/state: off]
				over [face/state: on]
				away [face/state: off]
			]
		]
	]

	hot: make face/feel [
		engage: func [face action event index][
			if action = 'down [
				face/font/color: first face/colors
				do face/action
			]
		]
		over: func [face action event index][
			face/font/color: pick face/colors not action
			show face
			face/font/color: first face/colors
		]
	]

	button: make hot [
		redraw: func [face index] [
			face/edge: either face/state [face/edge-down][face/edge-up]
			face/text: first face/texts
			if all [face/state (length? face/texts) > 1] [face/text: second face/texts]
			if not string? face/text [face/text: form face/text]
		]
		engage: func [face action event index][
			switch action [
				down [face/state: on]
				up [if face/state [do face/action] face/state: off]
				over [face/state: on]
				away [face/state: off]
			]
			show face
		]
	]

	toggle: make button [
		engage: func [face action event index][
			if action = 'down [face/state: not face/state do face/action]
			show face
		]
	]

	rotary: make hot [
		redraw: func [face index] [
			face/text: pick face/texts face/state
			if not string? face/text [face/text: form face/text]
		]
		engage: func [face action event index][
			if action = 'down [
				face/state: face/state + 1
				if face/state > (length? face/texts) [face/state: 1]
				do face/action
			]
			show face
		]
	]

	edit-text: func [face evt action /local char ][
		char: evt/char
		switch/default char [
			#"^(7f)" [
				if system/view/caret-offset < length? face/text [
					remove skip face/text system/view/caret-offset
				]
			]
			#"^(BACK)" [
				if system/view/caret-offset > 0 [
					remove back skip face/text system/view/caret-offset
					system/view/caret-offset: system/view/caret-offset - 1
				]
			]
			#"^G" [
				clear face/text
				system/view/caret-offset: 0
			]
			#"^M" [
				either face/act-return [do action][
					insert skip face/text system/view/caret-offset newline
					system/view/caret-offset: system/view/caret-offset + 1
				]
			]
		][
			if any [ char >= #" " char = #"^I" ][
				insert skip face/text system/view/caret-offset char
				system/view/caret-offset: system/view/caret-offset + 1
			]
			;do action Next-focus
		]
		show face
	]

	focus: func [face /local tmp-face][
		if system/view/focal-face [
			tmp-face: system/view/focal-face
			system/view/focal-face: none
			show tmp-face
		]
		system/view/focal-face: face
		if face [
			if not string? face/text [face/text: either face/text [form face/text][copy ""]]
			system/view/caret-offset: length? face/text
			show face
		]
	]

	edit: make face/feel [
		redraw: func [face index][
			face/body/color: either face = system/view/focal-face [255.255.100][
				255.255.255]
		]
		engage: func [face act event index][
			switch act [
				down [focus face]
				up [system/view/focal-face: none show face]
				key [edit-text face event face/action]
			]
		]
	]
]

;--- Standard Styles -------------------------------------------

if CID-verbose [print "Make Styles"]

stylize [
	MAIN FACE [
		font: [color: white align: 'left]
		action: none
		state: false
		rules: none	; additive grammar
		after: none ; what to do after the face is made
		options: [] ; options that follow the style
		at-offset: false  ; face is already at its correct offset
		max-size: 0x0
	]

	TEXT MAIN [
		size: 400x20
		font: [style: 'bold valign: 'top shadow: 1x1]
		set [body edge] none
		colors: none
		after: [
			if string? text [trim/lines text]
			if action [
				feel: CID-feel/hot
				colors: reduce [font/color 240.140.40]
			]
			state: size-text self  ; using state as temp var
			if para [
				if para/origin [state: state + para/origin]
				if para/margin [state: state + para/margin]
			]
		;	print [size state]
			size/y: max size/y second state
			if not find options 'size [size/x: 5 + first state]			
		]
		rules: [set a-align ['center | 'right | 'left] (
			font: make font [align: a-align]
		)]
	]

	TITLE TEXT [
		size: 640x20
		font: [size: 24 style: 'bold valign: 'center color: 250.250.100 shadow: 3x3]
	]

	SUBTITLE TITLE [font: [size: 18 style: 'italic]]

	LABEL TEXT [
		font: [valign: 'middle]
		para: [wrap?: false]
	]

	FRAME MAIN [
		offset: 0x0
		feel: CID-feel/sensor
		edge: [color: 0.0.0 size: 3x3]
		font: [align: 'center]
		body: [effect: [fit]]
		after: [
			if all [body/image not find options 'size][
				size: body/image/size
			]
			if not body/image [body/effect: none]
			if all [body/image find options 'color][
				;body: make body []
				append body/effect reduce ['colorize body/color]
			]
		]
		rules: [
			some [; hh: (probe copy/part hh 3)
				'crop [set asize pair! | none (asize: 0x0)] 
					(body/effect: compose [crop (asize) (size) colorize (body/color)]) |
				set a-effect ['vflip | 'hflip  | 'blur | 'sharpen] (
					if not body/effect [body/effect: copy []]
					append body/effect a-effect
				) |
				'edge set a-color tuple! (edge: make edge [color: a-color])
			]
		]
	]

	IMAGE FRAME [set [edge para] none]

	BACKDROP IMAGE [
		after: append after [
			size: max-size
			at-offset: true
		]
	]

	BACKTILE IMAGE [
		after: append after [
			size: max-size
			at-offset: true
			body: make body []
			if body/effect [replace body/effect 'fit 'tile-face]
		]
	]

	BUTTON MAIN [
		size: 100x24
		font: [align: 'center style: 'bold]
		edge: [size: 2x2 effect: 'bezel color: 180.100.50]	;edge, border
		edge-up: edge
		edge-down: make edge [effect: 'ibezel]
		feel: CID-feel/button
		colors: [255.255.255 255.180.50]
		body: [color: 50.120.150]
		texts: []
		after: [
			insert texts text
			if body/image [
				if not body/effect [body/effect: copy [fit]]
				if find options 'color [append body/effect reduce ['colorize body/color]]
			]
		]
		rules: ['alt some [set atext string! (append texts atext)]]
	]

	TOGGLE BUTTON [
		feel: CID-feel/toggle
	]

	ROTARY BUTTON [
		state: 1
		feel: CID-feel/rotary
	]

	FIELD MAIN [
		size: 200x24
		body: [color: 240.240.240]
		edge: [effect: 'ibezel]
		font: [color: 0.0.0 style: 'bold]
		para: [wrap?: on]
		feel: CID-feel/edit
		after: [
			if not string? text [text: either text [form text][copy ""]]
		]
		act-return: true
	]

	AREA FIELD [
		size: 400x150
		font: [valign: 'top]
		act-return: false
	]

]

;--- Test Function ---------------------------------------------

if CID-verbose [print "Make Layouts"]

if CID-test [
	view test-pane: layout 640x400 [
		at 300x270
		subtitle "CID Layout Tester"
		test-face: area {button "test" blue} 320x100
		xyp: across
	    button "View" [
	    	if error? err: try [
	    		view append copy test-pane layout 640x480 load test-face/text][
				probe disarm err
			]
	    ]
		button "Clear" [clear test-face/text show test-face]
		button "Quit" [quit]
		at (xyp + 0x30)
		button "Save as File" [write to-file cidf/text test-face/text]
		cidf: field "f.r"
	]
	quit
]