Archive version of: mini-edit-do.r ... version: 14 ... luce80 17-Apr-2021

Amendment note: Added Clean-script and a few fixes || Publicly available? Yes

REBOL [
	title: "Mini-edit-do"
	file: %mini-edit-do.r
	author: "Marco Antoniazzi"
	Copyright: "(C) 2012-2021 Marco Antoniazzi. All Rights reserved."
	email: [luce80 AT libero DOT it]
	date: 15-11-2020
	version: 0.8.6
	Purpose: "Helps test short programs (substitutes console)"
	History: [
		0.0.1 [30-04-2012 "First version"]
		0.5.1 [01-05-2012 "Fixed using view and quit"]
		0.5.2 [05-05-2012 "Added undo and redo"]
		0.5.3 [10-05-2012 "Fixed last probe"]
		0.5.4 [12-05-2012 "Added halt and other minor fixes"]
		0.5.5 [20-05-2012 "Fixed error inside prin and script header"]
		0.5.6 [03-06-2012 "Fixed bug when deleting all"]
		0.5.7 [08-06-2012 "Fixed undo after clear all"]
		0.5.8 [29-07-2012 "Fixed arg1 etc. in err?"]
		0.5.9 [09-08-2012 "Fixed ^X and save after clear all, arg1, do-face"]
		0.6.1 [03-01-2013 "Added pseudo-console"]
		0.6.2 [03-01-2013 "Fixed focus before undo/redo"]
		0.6.3 [16-03-2013 "Fixed last line being a comment"]
		0.6.4 [06-04-2013 "Fixed mini console button do script"]
		0.6.5 [16-06-2013 "Fixed mini console resizing"]
		0.6.6 [28-07-2013 "Improved word selection and skipping for area-scroll-style"]
		0.6.7 [30-12-2013 "Fixed word selection and skipping for area-scroll-style"]
		0.7.0 [25-01-2014 "Added mini-source level debugger"]
		0.7.1 [14-05-2017 "Fixes bug when closing foreing window"]
		0.8.0 [09-09-2017 "Added live VID and live Draw"]
		0.8.1 [05-11-2017 "Added until to Mini SLD"]
		0.8.2 [26-12-2017 "Added select all for area-scroll-style"]
		0.8.3 [25-04-2018 "Modified ask_close request"]
		0.8.4 [02-01-2019 "Added Clean-script, Fixed debugger-results resizing, Patched ctx-edit"]
		0.8.5 [15-11-2020 "Added Show commands, Fixed VID&Draw-results resizing, Added edge to radio-lines"]
	]
	comment: {30-Apr-2012 GUI automatically generated by VID_build. Author: Marco Antoniazzi.
		Derived directly from ParseAid.r
	}
	library: [
		level: 'intermediate
		platform: 'all
		type: 'tool
		domain: [debug testing]
		tested-under: [View 2.7.8.3.1]
		support: none
		license: 'BSD
		see-also: %parse-aid.r
	]
	todo: {
		- options: 
			- set max area-results length
			- set max dumped obj length
			- choose between head or tail of dumped obj
			- gui and text colors
		- patch ALL functions to use err? (to output errors to my prog)
		- patch loops by inserting "wait 0" to allow halting infinite loops
		- add "Mini help/source" and/or Dictionary or buttons "Show help" and "Show source"
		- add profiler (use Gregg Irwin's "profile" ?)
		- add parse-aid.r
		- add obj-recontruct.r (mold objects)
		- add watched variables
		- save win pos and size
		- "live" error check in console (after every typed word)
		- resize live draw image, save live draw image
		- button to open Rebol console (-> confirm "Closing the console window will quit the program")
		- buttons to show help for VID and Draw
		- button to unset recently setted values
	}
	Help: {
		The *MINI* source level debugger is REALLY minimal (and buggy). I can not patch "if" and "either" so
		you have to write "dif" and "deither" to use a patched version.
	}
	program-preferences-do-not-touch-01: #{0357007F02C0026F} ;DO NOT TOUCH!;;
]
; err?
	err?: func [blk /local arg1 arg2 arg3 message err][;derived from 11-Feb-2007 Guest2
		if not error? set/any 'err try blk [return get/any 'err]
		err: disarm err
		arg1: any [attempt [get in err 'arg1] 'unset]
		arg2: get in err 'arg2
		arg3: get in err 'arg3
		message: get err/id
		if block? message [bind message 'arg1]
		prin* ["** ERROR:" form reduce message newline]
		prin* ["** Near:" either block? err/near [mold/only err/near][err/near] newline]
		throw
	]
; patches
	doing: false
	old-length: 0
	old-prin: :prin old-print: :print ; use these to output to console
	old-probe: func [value] [old-print mold :value :value]
	old-quit: :quit
	quit: does [
		; closing all windows (except ours) is similar to quitting ...
		foreach face next System/view/screen-face/pane [unview/only face]
	]
	halt: does [] ; avoid opening console
	prin*: func [value][
		set-face/no-show output-face append get-face output-face form reduce value
		system/view/vid/vid-feel/move-drag output-face/vscroll/pane/3 1 ; autoscroll down
	]
	prin: func [value] [
		either all [(100000 + old-length) > length? get-face output-face doing] [ ; avoid fill mem
			set-face/no-show output-face append get-face output-face form err? [reduce value]
			system/view/vid/vid-feel/move-drag output-face/vscroll/pane/3 1 ; autoscroll down
			wait 0.0001 ; avoid blocking the gui
		][
			if confirm/with "ERROR. Probable infinite loop. Clear Results?" ["Yes" "Cancel"] [reset-face output-face]
			throw
		]
		exit ; force unsetting result
	]
	print: func [value] [prin value prin newline]
	probbed: none
	probe: func [value] [probbed: get 'value print mold :value :value]
	*isolator: context [
		func: make function! [
		    "Defines a user function with given spec and body." 
		    [catch] 
		    spec [block!] {Help string (opt) followed by arg words (and opt type and string)} 
		    body [block!] "The body block of the function"
		][
		    throw-on-error [make function! spec compose/deep [err? [(body)]]]
		]
		view: func ; taken from "REBOL Word Browser (Dictionary)" Author: "Carl Sassenrath"
			first get in system/words 'view
			head insert copy/deep second get in system/words 'view [new: true]
	]
	do-face: func [face value] [ ; (needs to work for functions and blocks)
		err?[do get in face 'action face either value [value][face/data]]
	]
	do-face-alt: func [face value] [
		err?[do get in face 'alt-action face either value [value][face/data]]
	]
	resize-face: func [
		"Resize a face."
		face
		size [number! pair!]
		/x "Resize only width"
		/y "Resize only heigth"
		/no-show "Do not show change yet"
		/local access
		][
		either all [
			access: get in face 'access
			in access 'resize-face*
		][
			access/resize-face* face size x y
		][
			face/size: size * (add 1x0 to-integer not x 0x1 to-integer not y)
		]
		if not no-show [show face]
		face
	]
	; make an unbound copy of ctx-text/edit-text and patch it
	change/part
		pick find pick find b: body-of get in ctx-text 'edit-text [if face: focal-face] 4 [tmp: tmp] 4
		[(any [face-edge 0x0])]
		1
	; re-make and re-bind the func
	ctx-text/edit-text: func spec-of get in ctx-text 'edit-text bind bind b ctx-text system/view
	unset 'b
;
context [ ; protect our functions from being redefined
; file, undo
	change_title: func [/modified] [
		clear find/tail main-window/text "- "
		either modified [append main-window/text "*" saved?: no][saved?: yes]
		append main-window/text to-string last split-path any [job-name %Untitled]
		main-window/changes: [text] show main-window
	]
	open_file: func [/local file-name job] [
		until [
			file-name: request-file/title/keep/only/filter "Load a Rebol file" "Load" "*.r"
			if none? file-name [exit]
			exists? file-name
		]

		job-name: file-name
		job: read file-name
		set-face input-face job
		code: copy job

		named: yes
		change_title
		saved?: yes
	]
	save_file: func [/as /local file-name filt ext response job] [
		;if empty? job [return false]
		if not named [as: true]

		if as [
			filt: "*.r"
			ext: %.r
			file-name: request-file/title/keep/only/save/filter "Save as Rebol file" "Save" filt
			if none? file-name [return false]
			if not-equal? suffix? file-name ext [append file-name ext]
			response: true
			if exists? file-name [response: request rejoin [{File "} last split-path file-name {" already exists, overwrite it?}]]
			if response <> true [return false]
			job-name: file-name
			named: yes
		]
		flash/with join "Saving to: " job-name main-window

		job: get-face input-face
		write job-name job
		code: copy job

		wait .8
		unview
		change_title
		saved?: yes
	]
	undo: does [
		if system/view/focal-face <> input-face/ar [focus input-face/ar]
		input-face/undo
		if strict-equal? code get-face input-face [change_title]
	]
	redo: does [
		if system/view/focal-face <> input-face/ar [focus input-face/ar]
		input-face/redo
		if strict-not-equal? code get-face input-face [change_title/modified]
	]
; do
	test: func [text /console /local script result temp] [
		if all [not console get-face check-clear-res] [clear-face area-results old-length: 0]
		if all [console get-face check-clear-res-cons] [clear-face area-console-results]
		err? [
			if all [console empty? trim text] [exit]
			probbed: none
			text: rejoin ["[" temp: copy text "^/]"]
			script: attempt [load/header text]
			if none? script [script: load text insert script make system/script/header [] ]
			system/script/header: script/1 ; replace our header with the script's one
			doing: true
			if all [console get-face check-commands] [print [">>" temp]]
			set/any 'result do bind script *isolator
			text: none recycle
			old-length: old-length + length? get-face area-results
			if not unset? get/any 'result [
				temp: copy/part mold :result 100000
				if (length? temp) = 100000 [append temp "..."]
				either console [
					print ["==" temp]
				][
					if not equal? mold :probbed temp [ ; avoid reprinting last result
						print temp
					]
				]
			]
			doing: false
		]
		get/any 'result
	]
	test-code: {
	n: 1
	loop 10 [
		n: n + 1
		a: n
	]
	deither 1 > 0 [print 1 n: 3][print 2]
	}
	codeg: []
	stepped: false
	source-debug: func [/step /local eval_code] [
		if all [get-face check-clear-res-debug] [clear-face area-debug-results old-length: 0]
		if step [stepped: true]
		dprin: func [value] [
			;either all [(100000 + old-length) > length? get-face area-source doing] [ ; avoid fill mem
				set-face/no-show area-source append get-face area-source form err? [reduce value]
				system/view/vid/vid-feel/move-drag area-source/vscroll/pane/3 1 ; autoscroll down
				;wait 0.0001 ; avoid blocking the gui
			;][
			;	if confirm/with "ERROR. Probable infinite loop. Clear Results?" ["Yes" "Cancel"] [reset-face area-source]
			;	throw
			;]
			exit ; force unsetting result
		]
		dprobe: func [value] [probbed: get 'value dprin mold/only :value :value]
		; patch natives
		natives: [loop while until repeat for forall foreach ]
		foreach word natives[
			set load join 'native- word get word
		]
		loop: func [count [integer!] block [block!]] [native-loop count [eval_code block]]
		while: func [cond-block [block!] body-block [block!]] [native-while [eval_code cond-block] [eval_code body-block]]
		until: func [block [block!]] [native-until [eval_code block]]
		repeat: func ['word [word!] value [integer! series!] body [block!]] [native-repeat :word value [eval_code body]]
		for: func [[catch throw] 'word [word!] start [number! series! money! time! date! char!] end [number! series! money! time! date! char!] bump [number! money! time! char!] body [block!] ][native-for :word start end bump [eval_code body]]
		forall: func [[catch throw] 'word [word!] body [block!] ][forall :word [eval_code body]]

		; these are unpatchables so rename them
		dif: func [condition then-block [block!]] [if condition [eval_code then-block]]
		deither: func [condition true-block [block!] false-block [block!]] [either condition [eval_code true-block][eval_code false-block]]

		old-length: 0
		point_code: func [code] [
			;old-print ["=>" mold code]
			nl: new-line? code
			if nl [new-line code off]
			insert code ###>>
			if nl [new-line code on]
			clear-face area-source
			dprobe head codeg
			remove code
			if nl [new-line code on]
			;if block? code [eval_code]
		] 
		eval_code: func [[throw] code] [
			;old-print ["ent"  codeg]
			;if not doing [return 0]
			
			either step [
				either empty? codeg [
					codeg: load get-face area-test
					;if confirm "End of code reached. Reset it to beginning?" [codeg: load get-face area-test]
				][
					point_code code
					set [value codeg] do/next code
					print ["==" get/any 'value]
				]
			][
				native-while [not empty? code] [
					if not doing [codeg: tail codeg throw get/any 'value]
					point_code code
					set [value code] do/next code
					print ["==" get/any 'value]
					attempt [wait load get-face field-wait]
				]
				; show that we are at the end (because we have finished)
				insert tail code [
				###>>] ; keep this on a new line
				clear-face area-source
				dprobe head codeg
				remove back tail code
			]
			
			get/any 'value
		]
		doing: true
		;old-print "1stendev"
		catch[eval_code codeg]
		if not stepped [codeg: none recycle]
		;old-print "endev"
		
		doing: false
		old-length: old-length + length? get-face area-source
		; restore original natives
		foreach word natives[
			set word get load join 'native- word
		]
		;codeg: none
	]
; clean script
	script-cleaner: make object! [
		History: [
			"Volker Nitsch" 1.2.0 13-Apr-2005 "Applied romanos patch to work recursion- and 'break - less"
			"Carl Sassenrath" 1.1.0 29-May-2003 "Fixes indent and parse rule."
			"Carl Sassenrath" 1.0.0 27-May-2000 "Original program."
		]
		out: none
		spaced: off
		indent: ""
		emit-line: func [] [append out newline]
		emit-space: func [pos] [
			append out either newline = last out [indent] [
				pick [#" " ""] found? any [
					spaced
					not any [find "[(" last out find ")]" first pos]
				]
			]
		]
		emit: func [from to] [emit-space from append out copy/part from to]
		set 'clean-script func [
			{Returns new script text with standard spacing (pretty printed).}
			script [string!] "Original Script text"
			/spacey "Optional spaces near brackets and parens"
			/local str new
		] [
			spaced: found? spacey
			clear indent
			out: append clear copy script newline
			parse script blk-rule: [
				some [
					str:
					newline (emit-line) |
					#";" [thru newline | to end] new: (emit str new) |

					;does not work with break-less link
					;[#"[" | #"("] (emit str 1 append indent tab) blk-rule |
					;[#"]" | #")"] (remove indent emit str 1) break |
					;but we do not need recursion
					[#"[" | #"("] (emit str 1 append indent tab) |
					[#"]" | #")"] (remove indent emit str 1) |

					skip (set [value new] load/next str emit str new) :new
				]
			]
			remove out
			if (load script) <> load out [
				make error! "script-semantic changed"
			]
			out
		]
	]
	clean-area: func [/local text new-text][
		ctx-text/unlight-text
		text: get-face area-test
		area-test/ar/access/set-face* area-test/ar new-text: clean-script text ; bypass area-test set-face because it cleans undos (bug ?)
		area-test/ar/add_to_undo-list reduce ['r 1 copy text length? text]
		area-test/ar/add_to_undo-list reduce ['i 1 "" length? new-text]
		system/view/caret: tail area-test/ar/text
		focus area-test/ar
		show area-test/ar
	]
; gui 
	;do %gui/area-scroll-style.r ;Copyright: {GNU Less General Public License (LGPL) - Copyright (C) Didier Cadieu 2004} 
	;system/options/binary-base: 64 compress mold/only/flat load %gui/area-scroll-style.r
	err? [
	do decompress ; %area-scroll-style.r Copyright: {GNU Less General Public License (LGPL) - Copyright (C) Didier Cadieu 2004} 
		64#{
		eJztWd2P3LYRf9dfwW4e/AEouj0bqSHYPRQBiry0T0UQQNgLeBK1Uq2VVEl7u1fD/dv7mxmKonZ15z3HRV7i2FmJnBnOBznzGyrQndFhPzxUJlb0U/7HqCSQ0bRrqipW
		9KIO5VBgYl9nTayyxvQq0V1ErxsVdGY2Sq8Y1Vn269D8SjRhVfZDrPJ9nYIiHTZMd0qgeCboTWXSIdS0tpM5DYIiL49hX5WZ6cJWd3oUHKx2zb1RWskcxKVNl5X1Vg3m
		OKi8NFWmxCoMfr9SwZCrlczp1OC9x7swR0IHKXaKrOr0Vq101TfKvgyFUSf0RFo1qa7UsGtJl0GVfQCDgzJXdVObGzXkEamtEnMsyeCyj2msJ9+HymRbE9IzEULFXRur
		XVmr9XENSSCw7NFOd1uMTwNNV8oA+ZokhGwbSYGP+jzSRwiAkVGmB4zs9FFdiWwnQ8yIYq0iZRBzOAAa0Pv7v4A4kReYsybF89ERCYTaR5FX9iKD1lhDIWYK+qI5QJGA
		dkcXq/txixXjQ1/lMXsJtDwUHspsKGK1/kEFB0QTrtJta+pM6fpBJTyk0qbF84acbEWqpDaHyMkfuj32RbftsXDhUxRLFGMoZW2VwMyyHszWdDdMEl0L81xDmdmomnxu
		JeHkZGFTV9Aur/Q2pL0EgoOaJixlsx+wIMX+lNSbYVp2XpqavqcIfjRKXmB7bwZmez0eCJZxr6u9IdfQW8zbOdKdCuSBeSPHqSYWS5EbU+Gk/mvfD/bM9UIUpJXRcjyi
		6Qj7o5QHeJRU3i4pt5Ef6BPRVt1Y9kXCU/35OA3K7Nrh4UaGebtbiae5BcrsoXXyosN+5A0zsVSm3g6FJ2SzmfvH08oa/6RvAg79Yji+EAiP6xkL0VE/DzwNj8txcpGk
		gP3Nz24YCePltXotB0rTyeAp3nHuKRJpV8erzSv2Pc+40xb4r1GT5zAjOsqC0y9WklW9gxNsJnHFXFwxF/dgxbjfx8SNW8q3+UzjmcLiQ0iUnyWVZhpZ+qO1y1vzsUhh
		LpCjK9mrrMuBjizlO9Q2pOhW19DWpjJWgBPyodPtjUpcoqLkKNMcqjvUmo83YKsarHStPrjNLENUaWVFS7J+d/W9/Udqu1TDStBr73QkjRTlaUozobi6NalsmhcMC2DB
		PXZd/9APZhfdl8hXgVfwnTUuFXhjT+ADa9efNrZurq/wR713tk3HOukMF/07nX5Ugy6raY68VPemGyJOtAVSrsfIatBSNmPNkpXAnEL3I1ohJWym8da29RskKCCUir08
		eLa0W0BWhd+iFD6kUg1wlRbAJ52dxHKjYVSVMTgIhMEkig/9/y05FaWJV1mYf8ObbWk3UsrhgPLq4X3Zl3cV4j/qM1bpKg8ctFv2xGTRuSemuaeCcJknnjCSnfAlT30b
		T5xTjhuWB61rhBFYiS2VghSkw5GhGDJpOQgow9pps2ubHiWpL8p8UC9zIEvzCsP1gKPu3j8auK3ZUSrfzJzFW94q+ptXAHQsyIaNZKmdrjVgqJwDsZKoLLIFPlBp1QLW
		kcuRKqzxnJHSQgMnEfV3q9sfV+QLvDA208hfTtOirGjNGxVYnMncJBp8v6yQySwbcj8smJY6lRB2ut4CLZ8lFL/ml3VmjjdWYzr7sl2cWCVF5saziUG71Y2QBqkGbXiL
		RpnJ9b7CZmtCiw3Z5CR4x3gRz7FqSwSIozRtqTXO0ZfVPGEiyesNgZL19Z9P5D9X9KLUN0+xluessJrCjLxMElRwff1MAdg9MYNgPJXtXaO7LI6iqXZVLYt9+7RJFsjN
		MJzAN47dszQSbwTC+XttOYdqczCrH95+9+nHn97942/bDx8+2+11iU0sbrSHReJE/WxP1HNkXBClwP1HtaLSg8n8Ep8OZVOPbTwSaSQjgjYs5Kcf7vwEjAfSnNI7PakA
		zbqxAIEG3StBps5Scj8dEFCNx7bVQZsbovDbqEQwFOtDA1QekBJFEj0hnzJYkhELnObIjZGS5WDQNGoRM2yzFcd2aLPsrO4otsnUG4Z5WUG3GHWRXMPOcxyIWB9ykuEa
		SKeONuen259uw9v/3v799pfbn2//+ZkLdacPswaACijyv5+c0Zvz1AtrlIWPjO0cYAymV+dNLbB88imLmdrYN+r9h3kfJeL4OHGi8gYlcyVrhQLOclAjPAiJGKDKhLbB
		WWD/Eo9sRyijt+bMI+beIMK2kgE4UF7fuMRuUUfWHGpx26nJWdlr1P7MYZ6pQoTm33tdWTpS6rWnFXmvSfeubxMgRbpEWbOHxBBnjLyyVMtZwNdU80VkcJE0uhARYZXJ
		nylLeBdEeXqR94LJfeIJ4U/GLCg+LMAkWVeyUrI4HFtqC8aCUyIc3dhmXDpPkvRZe1lapjgwzsx9Lbz0InvKW+MCabYt7JAV3a0WIcqxdQdq7Zy14+7xlrhghf+fr76l
		qdz4HvTDmFuE7C1wZnMvt5szWXwxebyaD4bejYVASf8Gg5/n16LTkLsYfe49xyRibL9JV1KNVCRAGHoXreyUUxZQUJL5Wh/jEAELnPj6zNgzUz1XuTAQWlm8Qdq3NtWN
		obGe8YLphHAoh3JH+YyDtxQjaIJBuTEYt4eLNHljDDA9/xHXC9z3jSMuONBmDnHZo5Vd+jnRk/gYmp6Cl2meEqjXPXqMFoj+lYDoNPq13fFUVKbm+DJJj1YnaWQFO8wL
		nGCGLQLhAJQFssseHiHIfPL0Hhj+8PGXhc8MFOBfYBH6gjSfOvnyNX5zYZVAPS48OgKP41Gz5wm7sNVl5yD/WH/dvah/mQolr6YSXTxKEjgEbUHjCJ+lEIw9jQfIzQki
		F+Ru7zb3FCy+bnEf4VC2GKNxZ+AOprvAGelGD4NEldlRReRBhrT97BaTbm3pKlO9mFYASzK1MCR67F4WPqZYF3DbMYuQy5H+HerUPPDXUaGkL3G2PZuu0d0Xq7n5upeo
		+Z5X9oY7elDXVs50f148LWdkPc4lrq0ce7/nKZtMzy5M0ycL9/1BAkvv0xloNWB1SDuSDlXMB0+uxfjjHVq5XTkgPK61STafPr98Fa4CdDV9y99KxrmVug1XKoAC4TiD
		w12ZHR1PaZ98oYqJIOVj2YYek90kA/XoKaJ5QFtPRY8ymyOTegKiKAYVMpda0XU0BrAFIVA5fjxs7CIXLLAsXF8gfO6vp9aYOeGZS7kkSh8yeU1/Lds32bYSPzHz8+eK
		pkdmd3KtF+e+Z+I1XVUt0s2Dx6SUgPAU+JrR9dhv0cxTx1MAxOGa/nq6nSkUrkd9gs3/ACE8X6Y9IQAA
	}
	]

	resize-faces: func [siz [pair!] /move] [
		foreach [face dir] reduce [text-results 0x1 area-results 0x1 field-console 0x1 text-command 0x1 text-debug-results 0x1 area-debug-results 0x1 area-vid-results 0x1 area-draw-results 0x1] [face/offset: face/offset + (siz * dir)]
		foreach [face dir] reduce [area-test 1x1 area-results 1x0 field-console 1x0 area-console-results 1x1 area-source 1x1 area-debug-results 1x0 area-vid 0x1 panel-gui 1x1 area-draw 0x1 box-drawings 1x1] [resize-face/no-show face face/size + (siz * dir)]
		either not move [
			foreach [face dir] reduce [panels 1x1 panel-edit 1x1 panel-console 1x1 panel-debug 1x1 panel-vid 1x1 panel-draw 1x1] [resize-face/no-show face face/size + (siz * dir)]
		][
			; "undo" vertical moving and resizing
			foreach [face dir] reduce [field-console 0x-1 text-command 0x-1 area-vid-results 0x-1 area-draw-results 0x-1] [face/offset: face/offset + (siz * dir)]
			foreach [face dir] reduce [
				area-results 0x-1 area-console-results 0x-1 area-debug-results 0x-1
				area-vid 0x-1 panel-gui 0x-1 area-draw 0x-1 box-drawings 0x-1
				;panel-vid 0x-1 panel-draw 0x-1
			] [resize-face/no-show face face/size + (siz * dir)]
		]
	]
	feel-move: [
		engage-super: :engage
		engage: func [face action event /local prev-offset] [
			engage-super face action event
			if find [over away] action [
				prev-offset: face/offset
				face/offset: 0x1 * (face/old-offset + event/offset) ; We cannot modify face/old-offset but why not use it?
				face/offset: 0x1 * second confine face/offset face/size area-test/offset + 0x100 area-results/offset + area-results/size - 0x100
				face/offset: face/offset + 4x0 ; ?? must add spacing

				if prev-offset <> face/offset [
					resize-faces/move (face/offset - prev-offset * 0x1)
					show main-window
				]
			]
		]
	]
	append system/view/VID/vid-styles area-style ; add to master style-sheet
	; panels
		panel-edit: layout/tight [
			do [sp: 4x4] origin sp space sp
			Across
			btn "(O)pen..." #"^O" [open_file]
			btn "(S)ave" #"^S" [save_file]
			pad (sp * -1x0)
			btn "as..." [save_file/as]
			btn "Undo" #"^z" [undo]
			btn "(R)edo" #"^r" [redo]
			btn "(D)o script" #"^D" 70 yellow [test get-face area-test]
			btn "Ha(l)t" #"^L" red [if doing [doing: false make error! "Halt"]]
			btn "Clear (T)est" #"^T" [if confirm "Are you sure?" [clear-face area-test job-name: none named: no change_title/modified]]
			btn "Clear R(e)sults" #"^e" [clear-face output-face old-length: 0]
			pad 0x1
			check-clear-res: check-line "before every do" off no-wrap font []
			return
			text-test: text bold "Test"
			pad 118x-3
			btn "Clea(n) script" #"^n" [clean-area]
			Below
			style area-scroll area-scroll 650x200 hscroll vscroll font-name font-fixed para [origin: 2x0]; Tabs: 16]
			area-test: area-scroll {print "Hello world!"} with [append init [deflag-face self/ar 'tabbed ]]
			button-balance: button "-  -  - - ----- - -  -  -" 650x6 gray feel feel-move edge [size: 1x1] font [size: 6]
			text-results: text bold "Results"
			area-results: area-scroll silver read-only
		]
		{panel-console: layout/tight [
			do [sp: 4x4] origin sp space sp
			style area-scroll area-scroll 650x200 hscroll vscroll font-name font-fixed para [origin: 2x0]; Tabs: 16]
			area-console: area-scroll {>> probe "Hello world!"} panel-edit/size - 1x1 - 8x8 with [append init [deflag-face self/ar 'tabbed ]]
			do [
				super-engage: get in area-console/ar/feel 'engage
				area-console/ar/feel/engage: func [face action event /local code result][
					either #"^M" = event/key  [
						set-face/no-show area-console append get-face area-console newline ; append newline
						code: find/tail/last get-face area-console {>> }
						;insert console-history code
						result: test/console rejoin ["[" copy code "]"]
					][
						super-engage face action event
					]
				]
			]
		]}
		console-history: copy []
		panel-console: layout/tight [
			do [sp: 4x4] origin sp space sp
			style area-scroll area-scroll hscroll vscroll font-name font-fixed para [origin: 2x0]; Tabs: 16]
			across
			check-commands: check-line "Show commands" off no-wrap font [] ; use new (empty) font because fonts are shared also with radio-lines
			pad 128
			btn "Do script" 70 yellow [do-face field-console none]
			btn "H(a)lt" #"^A" red [if doing [doing: false make error! "Halt"]]
			pad 77
			btn "Clear R(e)sults" #"^e" [clear-face output-face old-length: 0]
			pad 0x1
			check-clear-res-cons: check-line "before every do" off no-wrap font []
			below
			text bold "Results =="
			area-console-results: area-scroll panel-edit/size - 8x108 silver read-only
			text-command: text bold "Command >>"
			field-console: field {probe "Hello world!"} panel-edit/size/x - 1 - 8 font-name font-fixed with [
				append init [deflag-face self 'tabbed deflag-face self 'on-unfocus]
			] feel [
				super-engage: :engage
				engage: func [face action event /local code][
					if action = 'key [
						switch event/key [
							up [
								console-history: back console-history
								code: pick console-history 1 
								if code [set-face face code focus face]
							]
							down [
								console-history: next console-history
								if tail? console-history [console-history: back console-history]
								code: pick console-history 1
								if code [set-face face code focus face]
							]
						]
					]
					super-engage face action event
				]
			] [ ; action function
				if get-face check-clear-res-cons [clear-face area-console-results] 
				use [code][
					code: copy get-face face
					code: any [pick parse/all code "^/" 1 ""]
					if (pick back tail console-history 1) <> code [console-history: back insert tail console-history code]
					test/console code
				]
			]
		]
		panel-debug: layout/tight [
			do [sp: 4x4] origin sp space sp
			Across
			pad 27x0
			btn "Ste(p) debug" #"^p" 70 yellow [if not stepped [codeg: load get-face area-test] doing: true source-debug/step]
			text "Speed (wait)" -1x22 middle
			field-wait: field "0.1" 30x22
			text "secs" -1x22 middle
			btn "R(u)n debug" #"^u" 70 yellow [codeg: load get-face area-test doing: true source-debug]
			btn "H(a)lt" #"^A" red [if doing [doing: false ]]
			pad 77
			btn "Clear R(e)sults" #"^e" [clear-face output-face old-length: 0]
			pad 0x1
			check-clear-res-debug: check-line "before every do" off no-wrap font []
			return
			Below
			style area-scroll area-scroll 650x200 hscroll vscroll font-name font-fixed para [origin: 2x0]; Tabs: 16]
			text-source: text bold "Source"
			area-source: area-scroll silver read-only with [append init [deflag-face self/ar 'tabbed]]
			;button-balance: button "-----" 650x6 gray feel feel-move edge [size: 1x1] font [size: 6]
			pad 0x10 ; keep below widgets aligned with panel-edit
			text-debug-results: text bold "Results"
			area-debug-results: area-scroll silver read-only
		]
		panel-vid: layout/tight [
			do [sp: 4x4] origin sp space sp
			Across
			btn "(O)pen..." #"^O" [open_file]
			btn "(S)ave" #"^S" [save_file]
			pad (sp * -1x0)
			btn "as..." [save_file/as]
			btn "Undo" #"^z" [undo]
			btn "(R)edo" #"^r" [redo]
			btn "Refresh" 70 yellow [update-gui]
			pad 46x0
			btn "Clear VI(D)" #"^D" [if confirm "Are you sure?" [clear-face area-vid update-gui job-name: none named: no change_title/modified]]
			below
			guide
			style area-scroll area-scroll 230x395 vscroll font-name font-fixed para [origin: 2x0]; Tabs: 16] 
			text-vid: text bold "VID block"
			area-vid: area-scroll {across^/text "Hello world!"^/btn "OK" [alert "All right"]} hscroll with [
				append init [
					deflag-face self/ar 'tabbed
					self/ar/feel: make self/ar/feel [
						old-engage: :engage
						engage: func [face action event][	
							old-engage face action event
							if event/type = 'key [update-gui]
						]
					]
				]
			] 
			area-vid-results: area-scroll 230x35 silver read-only font-name font-sans-serif
			return
			text-gui: text bold "GUI" 
			panel-gui: panel 415x435 edge [size: 1x1] []
			do [attempt [panel-gui/pane: layout/offset load get-face area-vid 0x0]]
		]
		panel-draw: layout/tight [
			do [sp: 4x4] origin sp space sp
			Across
			btn "(O)pen..." #"^O" [open_file]
			btn "(S)ave" #"^S" [save_file]
			pad (sp * -1x0)
			btn "as..." [save_file/as]
			btn "Undo" #"^z" [undo]
			btn "(R)edo" #"^r" [redo]
			btn "Refresh" 70 yellow [update-draw]
			pad 46x0
			btn "Clear Dra(w)" #"^w" [if confirm "Are you sure?" [clear-face area-draw update-draw job-name: none named: no change_title/modified]]
			below
			guide
			style area-scroll area-scroll 230x395 vscroll font-name font-fixed para [origin: 2x0]; Tabs: 16] 
			text-draw: text bold "Draw block"
			area-draw: area-scroll {pen green^/fill-pen orange^/circle 30x30 20} hscroll with [
				append init [
					deflag-face self/ar 'tabbed
					self/ar/feel: make self/ar/feel [
						old-engage: :engage
						engage: func [face action event][	
							old-engage face action event
							if event/type = 'key [update-draw]
						]
					]
				]
			] 
			area-draw-results: area-scroll 230x35 silver read-only font-name font-sans-serif
			return
			text-drawings: text bold "Drawings" 
			box-drawings: box 415x435 white effect [draw [] ]; reduce [pen 0.100.0 fill-pen 100.100.0 circle 30x30 20]]
			do [attempt [box-drawings/effect/draw: load get-face area-draw]]
		]
		set 'output-face area-results ; make it global
		set 'input-face area-test ; make it global
	update-gui: has [lay][
		doing: true
		clear area-vid-results/ar/text
		area-vid-results/ar/colors/1: silver
		either attempt [lay: layout/offset compose/deep load get-face area-vid 0x0][
			panel-gui/pane: lay
			show panel-gui
			
			if "" <> get-face area-vid-results [area-vid-results/ar/colors/1: red + 100]
		][print "" area-vid-results/ar/colors/1: red + 100]
		show area-vid-results
		doing: false
	]
	update-draw: has [error][
		doing: true
		clear area-draw-results/ar/text
		area-draw-results/ar/colors/1: silver
		if any [ 
			error? set/any 'error try [box-drawings/effect/draw: compose/deep load get-face area-draw]
			error? set/any 'error try [show box-drawings]
			][
				; print mold error: disarm error ; does not work
				area-draw-results/ar/colors/1: red + 100
				box-drawings/effect/draw: copy [] ; FIXME: cannot clear ?!
		]
		show area-draw-results
		doing: false
	]
	show-pane: func [face [object!] pane [object!] input [object!] output [object!]][
		if get-face face [set 'output-face output set 'input-face input focus input panels/pane: pane show panels]
	]
	save_prefs: func [
		/local
		o
		s
		myself
		prefs-01
		][
		o: main-window/offset
		s: main-window/size
		prefs-01: mold to-binary reduce [
			shift o/1 8 o/1 // 256   shift o/2 8 o/2 // 256
			shift s/1 8 s/1 // 256   shift s/2 8 s/2 // 256
		]
		myself: read/string system/options/script
		change/part find/tail myself "program-preferences-do-not-touch-01: " prefs-01 length? prefs-01 
		write system/options/script myself
	]
	main-window: center-face layout [
		style radio-line radio-line -1x24 no-wrap para [margin: 6x2] edge [size: 1x1 color: black]
			feel [
				redraw-super: :redraw
				redraw: func [face action position][
					redraw-super face action position
					face/font/style: either face/data ['bold][none]
				]
			]
		do [sp: 4x4] origin sp space sp
		Across
		space 0x-1
		radio-line "Mini editor" on [show-pane face panel-edit area-test area-results]
		radio-line "Mini console" off [show-pane face panel-console field-console area-console-results]
		radio-line "Mini source level debugger" off [set-face area-source/ar get-face area-test show-pane face panel-debug area-source area-debug-results]
		;radio-line "Mini function builder" off
		btn-?: btn "?" sky keycode [f1] [
			ssh: System/script/header
			if not value? 'help-win [; avoid opening win more then once
				help-win: view/new layout [ below space sp
					text 600 bold center ssh/Title
					text 600 center rejoin ["Version: " ssh/Version either ssh/Version <> pick tail ssh/history -2 [rejoin [" (" pick tail ssh/history -2 ")"]][""] " , " ssh/Date ". Copyright (C) " now/year " " ssh/Author]
					text 600 bold center "USE AT YOUR OWN RISK"
					across
					info-help: info 600x100 as-is trim/auto ssh/Help wrap edge [size: 1x1]
					pad -20
					slider info-help/size/y * 0x1 + 16x0 with [append init [redrag 250 / 300]] [scroll-para info-help face]
					key (escape) (0x0 - sp) [unview]
				]
			]
		]
		radio-line "Live VID" off [show-pane face panel-vid area-vid area-vid-results]
		radio-line "Live Draw" off [show-pane face panel-draw area-draw area-draw-results]
		return
		panels: box panel-edit/size + 1x1 edge [size: 1x1] with [pane: panel-edit] ; + 1x1 is because edge [size: 1x1]
		at -1000x-10000
		key keycode [f2] [focus input-face]
		key escape (sp * 0x-1) [ask_close]
		do [
			code: copy area-test/text
			old-add_to_undo-list: get in area-test/ar 'add_to_undo-list
			area-test/ar/add_to_undo-list: func [key] [change_title/modified old-add_to_undo-list key]
		]
	]
	main-window/user-data: reduce ['size main-window/size]
	insert-event-func func [face event /local siz] [
		if event/face = main-window [
			switch event/type [
				close [
					;save_prefs
					ask_close
					return none
				]
				resize [
					face: system/view/screen-face/pane/1
					siz: face/size - face/user-data/size     ; compute size difference
					face/user-data/size: face/size          ; store new size

					resize-faces siz
					button-balance/offset: button-balance/offset + (siz * 0x1)
					button-balance/size: button-balance/size + (siz * 1x0)
					show face
				]
				scroll-line [either event/offset/y < 0 [scroll-drag area-test/vscroll scroll-drag/back/page area-test/vscroll ] [scroll-drag/back area-test/vscroll scroll-drag/page area-test/vscroll ]]
				;key [the-key: event/key]
			]
		]
		if all [event/type = 'close value? 'help-win event/face = help-win] [unset 'help-win]
		event
	]
	ask_close: does [
		either not saved? [
			switch request ["Save changes before exiting?" "Yes" "No" "Cancel"] reduce [
				yes [if save_file [old-quit]]
				no [old-quit]
			]
		][
			if confirm "Exit now?" [old-quit]
			;old-quit
		]
	]
; main
	
	job-name: none
	named: no
	saved?: yes

	min-main-window-size: main-window/size
	{
	; set prefs
	main-window/offset: to-pair reduce [
		to-integer copy/part at system/script/header/program-preferences-do-not-touch-01 1 2
		to-integer copy/part at system/script/header/program-preferences-do-not-touch-01 3 2
	]
	old-main-window-size: main-window/size
	main-window/size: main-window/user-data/size: to-pair reduce [
		to-integer copy/part at system/script/header/program-preferences-do-not-touch-01 5 2
		to-integer copy/part at system/script/header/program-preferences-do-not-touch-01 7 2
	]

	resize-faces main-window/size - old-main-window-size
	button-balance/offset: button-balance/offset + ((main-window/size - old-main-window-size) * 0x1)
	button-balance/size: button-balance/size + ((main-window/size - old-main-window-size) * 1x0)
	}

	main-title: join copy System/script/header/title " - Untitled"
	view/title/options main-window main-title reduce ['resize 'min-size min-main-window-size + system/view/title-size + 8x10 + system/view/resize-border]
] ; context