| View discussion [54 posts] | View script | License |
| Download script | History | Other scripts by: luce80 |
30-Apr 22:01 UTC
[0.077] 22.093k
[0.077] 22.093k
 | Archive version of: mini-edit-do.r ... version: 3 ... luce80 11-May-2012Amendment note: Fixed last probe || Publicly available? Yes REBOL [
title: "Mini-edit-do"
file: %mini-edit-do.r
author: "Marco Antoniazzi"
Copyright: "(C) 2011 Marco Antoniazzi. All Rights reserved"
email: [luce80 AT libero DOT it]
date: 10-05-2012
version: 0.5.3
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"]
]
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: none
]
todo: {
- ask to save before exit if something modified
- scroll-wheel
- options:
- set max area-results length
- set max dumped obj length
- choose between head or tail of dumped obj
}
]
; patches
old-length: 0
old-prin: :prin old-print: :print ; use these to output to console
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] [
either (100000 + old-length) > length? get-face area-results [ ; avoid fill mem
set-face area-results append get-face area-results form reduce value
system/view/vid/vid-feel/move-drag area-results/vscroll/pane/3 1 ; autoscroll down
][
alert "ERROR. Probable infinite loop."
reset-face area-results
throw
]
]
print: func [value] [prin value prin newline]
probbed: none
probe: func [value] [probbed: value print mold :value :value]
;
context [ ; protect our functions from being redefined
; file
change_title: func [/modified] [
clear find/tail main-window/text "- "
if modified [append main-window/text "*"]
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 rules file" "Load" "*.r"
if none? file-name [exit]
exists? file-name
]
job-name: file-name
job: read file-name
set-face area-test 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/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 area-test
write job-name job
wait 1.3
unview
change_title
saved?: yes
]
; do
err?: func [blk /local arg1 arg2 arg3 message err][;11-Feb-2007 Guest2
if not error? err: try blk [return :err]
err: disarm err
set [arg1 arg2 arg3] reduce [err/arg1 err/arg2 err/arg3]
message: get err/id
if block? message [bind message 'arg1]
print ["**ERROR:" form reduce message]
print ["**Near:" either block? err/near [mold/only err/near][err/near]]
none
]
test: func [/local result temp] [
if get-face check-clear-res [reset-face area-results old-length: 0]
err? [
set/any 'result do get-face area-test
old-length: old-length + length? get-face area-results
if not unset? get/any 'result [
if object? result [
if all [in result 'offset in result 'size in result 'pane] [; it is a face
view/new main-window ; re-open window closed by Rebol (!?)
]
if 10000 < length? temp: mold/only result [result: copy/part temp 10000 append result "..."]
]
if not equal? probbed result [probe result]
]
]
]
; gui
;do %area-scroll-style.r ;Copyright: {GNU Less General Public License (LGPL) - Copyright (C) Didier Cadieu 2004}
do decompress ; %area-scroll-style.r Copyright: {GNU Less General Public License (LGPL) - Copyright (C) Didier Cadieu 2004}
64#{
eJztWm1v3MYR/pz9FdMLCkuGT9TJTpqc4gipWyQB7CQokiAAQQUrck/HmEdeyT3p
FMP97X1mZrnknc4vTVL0S2NHIvdl3nZ25pmh//H3v377nFKzKCs3pz/b1tlpl7dN
VU07f1e5k9b40vPc5AvM0W3pl6QLXNuRrJkYu/HLpsWav5VF6Vp6ZvFrQ0e2Km1H
GHTPjifGrWxZzSlt3S9NWVM6KTCRT8g303xpW/r4CU182eXYNaEPJycTmizaSZaZ
wnoIcPbp9JdNdTc9Oz19Ym7AvWzqOc1OTk9OzXrTrpsOi16Z75dlR/hrqXa3xAqp
lCo6VnXlFd5AwJdgRbYukqYlyF/+2tQeI1G9E/O1J1tVzS11rnK5B0dqFuTd1lOz
8R3kJ78EsdLdWqYq7ECRlvYGb4TXYtrU1R2tmsKdmNfmWbO+a8vrpYesX37zAz13
XUdfutq14Pzd5qoqc3pe5q7uHB09//K758c0pbiJjp4d066R2RyvDZT2TXsH6xqx
CFvr9C9iK3q1KNsOWyFMdUxr5dFCIdu5k9eyfkazj6ann2L9bMbrt9RVUK6lorwp
2dB0dUenkKTa5O6TU910RmdPhk22KFxB3bJc+GmwVn29t+MxnYLNR7zjrN+xqYtG
TNY6PAzrM/wx6o98fHM5xfJXBw1HXjpXk8vZpsYwsTkVjesotW3Crxmd06Jpb21b
GGYxmubX8bQ5p4cPH5J40GJT63njmY84bza1d+3atp5dINwRvFrcne1UzSXvc9kL
aV6tGnGCYEqb501bsFHEfxalq4pAB4M4CL+gVzplc/fadHjVrUnvkWGGBW/tNSxY
dQ2FFxZybzlWVg37uF+tWQ7PypyTfWq3ZfcIL0/LGo5HHcz6CNNP+aF3cJNBhXJB
dVO7C/KLhHWj1G1Ln5mym/OQrJ+SK67dlJ95nQGzOa1wwWfbGTOc9puTlW2vMT4M
4M7pQIfrwASmoj+InNNXrsWdheGXDW62qMdin8Dv4Y0Op1g79sq8WYEWm1Wlb2ld
5i/FzGELgUVvEnOO83HwFlZbFUi29Hl8vqN0lqVnmcEyjPF2HESCCISBld3iEohq
UQUlnMwtJT1dGIDfP/sci1N9yUCVjRnOKgXJ8KjUyk4pMIcZrMFbTLfkwLPQezCn
m97jl/1DVy3mcj4muONtWfglYuLHH3zwwTkVbmE3lY+6k0z3Xv4NouMtHBLu3VC3
dnm5uKNbCycvhgj4aG9zuKi2IA5qJ0YI4A6u1w4Ttob5lGaOiEVpxj4U5KYU8TiJ
Svh2w+HyusvMcrxgeWBBL4PqRykMWULOa9deyIrkTPfuWkFnMqQBuJQSGsJxuqjs
9ZSvk6SJYUIXIriDHfv1/srRjC7F6ZyzPb/Ic4Typu1EtpY3zAmXr9KbubkSEuy0
bEMOscONNVY2s4e9dKQvsFznvDB+2IcUIXFjq43LkLKFA/9MbGv0t+xM4j4aNuiC
hXNVYotfNp0PIauTNdDi+hCzLA30E76YmcmRNNpDy94izWiP8nqXJK07qPhbmYz2
vDcTjjcjLmpdHg2cJCJoXDL6GEcRso7O6KF6PJ+x2kncIj7JyoxOt6fZMV9+mYi3
wYxfk2axgALJVtkNv8FImY5c22SR2nKX2nKX2l2gEn+/gVp/xiN974m7I60aD/T0
1wF5dsQJy7dBp4Hhm86HT1fzvwaWsi493weOd8AWC7O2Nd8uDTKG2Uswvm3t+oLS
GEM4NmYcCutGAd7JEM+wh0MV8R5yNcM3REa/LDGWNxXyCGDBHoBjRnLaV8irLy90
XUdn9JQqV1/7ZT+EuBdED0tmnwBk6f8Z2IjkHFgk+tqbpizA2nr6EUgSqY2gbwXU
CyeP0YcV1z0h4jyDcN714UUXMRrqrcZGIs4cHFWmevCI8+rADwQ3peZ8ZWsLr2Wo
ZLob3IXurvNulTCmFTw1rUpOz72xGTTtDQHI/eybn0eL9dba3AdT/SkLaGJ2iv/o
s2iuuIfLAsFLVzZ/SR6VwjDHGA17q3IFs7ht7hg3huWV7bwpgZZbn8g5LTk7DWRF
RgiioYui9CDJec83axljvNBUurGD5ymQXNpOtAjCu9Xa3+3IrGgIK5CvOHTHqfsi
DZxZGlg6yXEEjHsAXvMlKUgXk5myt0YieBN+IbgIk0h1/PMJzgF5UHgcmH7Ml+fQ
5cK9EmcQ1lOG9ly1RGEC5KgWJgtY+bAFBl3uWSBOve1Q3ssCb9OufQ8D/W4L3F/X
O7YMsknOSZxQ3tmfJH/DSXu6R1+/+OpbvqHAsqC8gYddcUkwVBc15X4rsFdyhFIC
dBSLiVKp6Vcgq5ReITJcmYEvI+NUai46WqAacMcYrj1CXHx/6WD+ZoVEhJs6Mrrc
M9X5d9OX2lQYZGI3jihTvUJqMF4UahGgEcqrNa4enxziVJbGsMptgAuh+OHk8tmE
7YAXAZEW4TzKuSwr5nhhAuKWzUwY236aIBqHXUiCED8yukdg2tr62l3cC2DsxShD
KX2APFEXbnsRxOVooi4XqZIm24uRQgYqBcnqxovG6Rt5qPMnPVhn5VMDPY74gI4n
lI6EkDOLZxguzN7gLMtke+Gqvd37G+/teSHry/vrMZdM+lU/vmkVTnWuxUFeleur
BiX1PEmGzFitMzHNwc2s90z85393bCiNpSUh3Si7QPrVLCPFZd8A0pqYbQgi6eig
BqOrKcVUWTjQN4v6NluAlRr86W8h8x7nYYY/CPiMOIqY1qWG1BzZBpQR+34CokO3
hEMebOtqxd8y5ztOCdKg024LImqiI4pjtJzgn1LGSnlhtMrmV34yVVm7gCd4LL4a
7bLwmPRfGGvHoj7ipQteMC7XUkGDIgm/Iz0gkikZfjKK1HRAn9khhv6hrW7tXUfs
nFwIKno76lyv8fEjblcUTf3ASx0tgG4XwcqewFK29zrMBb9mfW3+oim4GhfmnMQk
tXC2G/d6YmG+dDVx5OYuUiDwBTeG4CxDfyn2LW9xiRwNHbpN7YG1xt1MZnsiyTMU
pDv5ga7E8cHoqvRsDBDe1NIlxdVhN1UOyGz73c/4Pl2UFc5ljo3sEeJwkQlIdFPf
TEP+58vIbCaXX11OL/91+eLyp8sfL7+fBBD8QuGrmEph+9BnWzT5hnvUjJL7xsUI
zIsxb3dqawYfSHqjlAQ1ZOZBAPIB+QuajljfDK/REa2WZYM7CplBhMf02VA1jMhJ
341bWONB6WlROqPHmdJBZhzhdDgwUutUS9tD29+1RyMAhLHX7p5B3A3udp++4Yac
0CS7KmxTwFY0t7VixH2Vi7Lj4qroseKQGafunxtbhWUs08ORUGw8Ob+oFeNPFiUp
mg0IThHV2CiH4IsQeBeA4Q6T4pfKLRS+vC8p3XqA0oCEWFkTtVXBdXfapxBVeYkt
mtY0FaUHh+dhtUJPs78GMWYeUhrfnZDmWXTlrFNixqjjpta92u01PdGAD99NTBys
lW8z2oRk6Bz8CcGqjYr25zyi/27y9N+z0x+oJ0ofZAVKkSqXCDGV2424+nFiL+Ky
vU/GVJ8Y3Crtme9YQPrN29PdwenQhVJUPG5KyfNur30Yit32/7B1NVDo+yosKQvG
AjK6nY6a9xEDjLdgBVT8raeBewa0tece91S9p+hgp+HEDjcDN2s5QekGDOfH3ue4
1xDbW3xcwV6DP1Ckzu7gy5UTYq1bO+vfIwHLoGThiq423us3p/B9rjiRptSe7jpv
fYnaE9DgFhkZIkiVeTSeEOvBEnwbE3FUIXOs/nbIrUZArnf/6Jsc+nuX5Of/e+I7
TPeH+qgWAOek0ImTTUfyIeRAj5KDphr0jfBDS23Vg0lLObMP0IZ5Thyjun6YMHuZ
UsHCNTtpj5wU979BrQA9zuOHV/zlrybAC4u2WeFg4R3rihv/uoiJKCzdK0kahqD9
dz+cGXc2dnnufE3Q9DKGc6EAEuABSwDa8HfT3am9b709IBdFsTroM27r0APpWGOw
vzvhhsCz1rZsYwnXQ4XYch936bP0NGKJ5RsXwJBa1AQo2pc0krb6unVUILm9Ckkr
KamTjNkw3pEeWCw1kGEF+EmZFu+ZbUPV8QNiWOnvhu4WQlCuTep4TmaHYn8iIEZl
saWELc7wu9vpWvNnA25dw5ZRFOxIh5rVtrHgvP+pbPSxfvc4+6A9bph3/Zv8AwFd
15kuOmnousd/PxK/LMO+w8ed+J1z14C20zMfnxyFLy/JHZ2By5jJsmn3/k0Kcxk+
+izfzqUnvN3lNzP6ySQ0c0d6psNz7wbD97X4uUz9RoJWf3//DbYldGBHJAAA
}
rezize-faces: func [siz [pair!] /move] [
area-test/ar/line-list: none ; to reactivate auto-wrapping
text-results/offset: text-results/offset + (siz * 0x1)
area-results/offset: area-results/offset + (siz * 0x1)
resize-face/no-show area-test area-test/size + (siz * 1x1)
resize-face/no-show area-results area-results/size + (siz * 1x0)
if move [
resize-face/no-show area-results area-results/size + (siz * 0x-1)
]
]
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 [
rezize-faces/move (face/offset - prev-offset * 0x1)
show main-window
]
]
]
]
;append system/view/VID/vid-styles area-style ; add to master style-sheet
main-window: center-face layout [
styles area-style
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" [area-test/undo]
btn "(R)edo" #"^r" [area-test/redo]
btn "(D)o script" #"^D" yellow [test area-test]
btn "Clear (T)est" #"^T" [reset-face area-test]
btn "Clear R(e)sults" #"^e" [reset-face area-results old-length: 0]
pad 0x1
check-clear-res: check-line "before every do"
return
Below
style area-scroll area-scroll 600x200 hscroll vscroll font-name font-fixed para [origin: 2x0]; Tabs: 16]
text-test: text bold "Test"
area-test: area-scroll {print "Hello world!"} with [append init [deflag-face self/ar 'tabbed]]
button-balance: button "-----" 600x6 gray feel feel-move edge [size: 1x1] font [size: 6]
text-results: text bold "Results"
area-results: area-scroll silver read-only
key escape (sp * 0x-1) [ask_close]
]
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 [
ask_close
return none
]
resize [
face: main-window
siz: face/size - face/user-data/size ; compute size difference
face/user-data/size: face/size ; store new size
rezize-faces siz
button-balance/offset: button-balance/offset + (siz * 0x1)
button-balance/size: button-balance/size + (siz * 1x0)
show main-window
]
]
]
event
]
ask_close: does [
either not saved? [
switch request ["Exit without saving?" "Yes" "Save" "No"] reduce [
yes [old-quit]
no [if save_file [old-quit]]
]
][
if confirm "Exit now?" [old-quit]
;quit
]
]
; main
job-name: none
named: no
saved?: yes
main-title: join copy System/script/header/title " - Untitled"
view/title/options main-window main-title reduce ['resize 'min-size main-window/size + system/view/title-size + 8x10 + system/view/resize-border]
] ; contextNotes
|