967 lines
26 KiB
Tcl
967 lines
26 KiB
Tcl
#!/usr/bin/env tclsh
|
|
#
|
|
# Genoa Banner Creator: a tool to generate original art.
|
|
# Copyright 2023 Felix Pleșoianu <https://felix.plesoianu.ro/>
|
|
#
|
|
# Permission is hereby granted, free of charge, to any person obtaining a copy
|
|
# of this software and associated documentation files (the "Software"), to deal
|
|
# in the Software without restriction, including without limitation the rights
|
|
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
|
|
# copies of the Software, and to permit persons to whom the Software is
|
|
# furnished to do so, subject to the following conditions:
|
|
#
|
|
# The above copyright notice and this permission notice shall be included in
|
|
# all copies or substantial portions of the Software.
|
|
#
|
|
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
|
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
|
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
|
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
|
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
|
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
|
|
# THE SOFTWARE.
|
|
|
|
package require Tcl 8.6
|
|
package require Tk 8.6
|
|
|
|
package require ctext
|
|
package require getstring
|
|
namespace import getstring::*
|
|
|
|
set window_title "Genoa Banner Creator"
|
|
|
|
set about_text "Tool to Generate Original Art\nv1.0 beta (18 Sep 2023)"
|
|
set credits_text "Made by No Time To Play\nMIT License"
|
|
set site_link "https://notimetoplay.org/graphics/genoa/"
|
|
|
|
namespace path {::tcl::mathop ::tcl::mathfunc}
|
|
|
|
set drawing(color) "black"
|
|
set drawing(fill) ""
|
|
set drawing(font) "Times"
|
|
set drawing(size) "10"
|
|
set drawing(width) 1
|
|
set drawing(dash) ""
|
|
|
|
set d_list {}
|
|
|
|
set meta(width) 200
|
|
set meta(height) 200
|
|
set meta(viewBox) "0 0 200 200"
|
|
|
|
set overlay {0 0 200 200}
|
|
|
|
interp create -safe runner
|
|
interp limit runner commands -value 1000000
|
|
|
|
runner eval {
|
|
proc repeat {times code} {
|
|
for {set i 0} {$i < $times} {incr i} {
|
|
set ret [catch {uplevel 1 $code} message]
|
|
switch $ret {
|
|
0 {}
|
|
1 {
|
|
return -code error \
|
|
-errorinfo $::errorInfo \
|
|
-errorcode $::errorCode \
|
|
$message
|
|
}
|
|
2 { return -code return $message }
|
|
3 { break }
|
|
4 {}
|
|
default { return -code $code $message }
|
|
}
|
|
}
|
|
}
|
|
namespace path {::tcl::mathop ::tcl::mathfunc}
|
|
}
|
|
|
|
proc line {x1 y1 x2 y2} {
|
|
global d_list drawing
|
|
lappend d_list [dict create type "line" \
|
|
coords [list $x1 $y1 $x2 $y2] \
|
|
x1 $x1 y1 $y1 x2 $x2 y2 $y2 \
|
|
-outline $drawing(color) -width $drawing(width) \
|
|
-dash $drawing(dash)]
|
|
}
|
|
|
|
proc box {x y w h} {
|
|
global d_list drawing
|
|
lappend d_list [dict create type "box" \
|
|
coords [list $x $y [+ $x $w] [+ $y $h]] \
|
|
x $x y $y width $w height $h \
|
|
-outline $drawing(color) -width $drawing(width) \
|
|
-fill $drawing(fill) -dash $drawing(dash)]
|
|
}
|
|
|
|
proc circle {cx cy r} {
|
|
global d_list drawing
|
|
set coords [list [- $cx $r] [- $cy $r] [+ $cx $r] [+ $cy $r]]
|
|
lappend d_list [dict create type "oval" coords $coords \
|
|
cx $cx cy $cy rx $r ry $r \
|
|
-outline $drawing(color) -width $drawing(width) \
|
|
-fill $drawing(fill) -dash $drawing(dash)]
|
|
}
|
|
|
|
proc oval {cx cy rx ry} {
|
|
global d_list drawing
|
|
set coords [list [- $cx $rx] [- $cy $ry] [+ $cx $rx] [+ $cy $ry]]
|
|
lappend d_list [dict create type oval coords $coords \
|
|
cx $cx cy $cy rx $rx ry $ry \
|
|
-outline $drawing(color) -width $drawing(width) \
|
|
-fill $drawing(fill) -dash $drawing(dash)]
|
|
}
|
|
|
|
proc make_text {x y t} {
|
|
global d_list drawing
|
|
lappend d_list [dict create type "text" coords [list $x $y] \
|
|
x $x y $y -text $t -fill $drawing(color) \
|
|
-font [list $drawing(font) $drawing(size)] \
|
|
font-family $drawing(font) font-size "$drawing(size)pt"]
|
|
}
|
|
|
|
proc polygon args {
|
|
global d_list drawing
|
|
lappend d_list [dict create type "polygon" coords $args \
|
|
-outline $drawing(color) -width $drawing(width) \
|
|
-fill $drawing(fill) -dash $drawing(dash)]
|
|
}
|
|
|
|
proc color c {
|
|
global drawing
|
|
set drawing(color) $c
|
|
}
|
|
|
|
proc fill f {
|
|
global drawing
|
|
set drawing(fill) $f
|
|
}
|
|
|
|
proc width w {
|
|
global drawing
|
|
set drawing(width) $w
|
|
}
|
|
|
|
proc set_font f {
|
|
global drawing
|
|
set drawing(font) $f
|
|
}
|
|
|
|
proc size s {
|
|
global drawing
|
|
set drawing(size) $s
|
|
}
|
|
|
|
proc dash args {
|
|
global drawing
|
|
set drawing(dash) $args
|
|
}
|
|
|
|
proc viewport {x y w h} {
|
|
global meta overlay
|
|
set meta(viewBox) "$x $y $w $h"
|
|
set meta(width) $w
|
|
set meta(height) $h
|
|
set overlay [list $x $y [+ $x $w] [+ $y $h]]
|
|
}
|
|
|
|
runner alias line line
|
|
runner alias box box
|
|
runner alias circle circle
|
|
runner alias oval oval
|
|
runner alias text make_text
|
|
runner alias polygon polygon
|
|
runner alias color color
|
|
runner alias fill fill
|
|
runner alias width width
|
|
runner alias dash dash
|
|
runner alias font set_font
|
|
runner alias size size
|
|
runner alias viewport viewport
|
|
runner alias alert alert
|
|
|
|
set file_types {
|
|
{"Genoa scripts" ".tcl"}
|
|
{"All files" ".*"}
|
|
}
|
|
|
|
set file_name ""
|
|
set search_term ""
|
|
|
|
set _word_wrap 1
|
|
set _line_nums 1
|
|
|
|
namespace eval font_size {
|
|
variable minimum 6
|
|
variable default 11
|
|
variable maximum 16
|
|
|
|
namespace export increase decrease reset
|
|
namespace ensemble create
|
|
|
|
variable current $default
|
|
|
|
proc increase {widget {family "Courier"}} {
|
|
variable current
|
|
variable maximum
|
|
if {$current < $maximum} {
|
|
incr current
|
|
}
|
|
$widget configure -font "$family $current"
|
|
}
|
|
|
|
proc decrease {widget {family "Courier"}} {
|
|
variable current
|
|
variable minimum
|
|
if {$current > $minimum} {
|
|
incr current -1
|
|
}
|
|
$widget configure -font "$family $current"
|
|
}
|
|
|
|
proc reset {widget {family "Courier"}} {
|
|
variable current
|
|
variable default
|
|
set current $default
|
|
$widget configure -font "$family $current"
|
|
}
|
|
}
|
|
|
|
namespace eval tk_util {
|
|
proc pack_scrolled widget {
|
|
set parent [winfo parent $widget]
|
|
if {$parent == "."} {
|
|
set scroll .scroll
|
|
} else {
|
|
set scroll $parent.scroll
|
|
}
|
|
ttk::scrollbar $scroll -orient "vertical" \
|
|
-command "$widget yview"
|
|
pack $widget -side "left" -fill "both" -expand 1
|
|
$widget configure -yscrollcommand "$scroll set"
|
|
pack $scroll -side "right" -fill y
|
|
}
|
|
|
|
proc load_text {widget content} {
|
|
$widget delete 1.0 end
|
|
$widget insert end $content
|
|
$widget edit reset
|
|
$widget edit modified 0
|
|
}
|
|
|
|
proc text_selection widget {
|
|
if {[llength [$widget tag ranges sel]] > 0} {
|
|
return [$widget get sel.first sel.last]
|
|
} else {
|
|
return ""
|
|
}
|
|
}
|
|
|
|
proc paste_content widget {
|
|
if {[llength [$widget tag ranges sel]] > 0} {
|
|
$widget delete sel.first sel.last
|
|
}
|
|
tk_textPaste $widget
|
|
}
|
|
|
|
proc select_all widget {
|
|
$widget tag remove sel 1.0 end
|
|
$widget tag add sel 1.0 end
|
|
}
|
|
|
|
proc highlight_text {widget content {start "1.0"}} {
|
|
set idx [$widget search -nocase $content $start]
|
|
if {$idx ne ""} {
|
|
set len [string length $content]
|
|
set pos "$idx +$len chars"
|
|
$widget tag remove "sel" "1.0" "end"
|
|
$widget tag add "sel" $idx $pos
|
|
$widget mark set "insert" $pos
|
|
$widget see "insert"
|
|
focus $widget
|
|
}
|
|
return $idx
|
|
}
|
|
|
|
proc word_wrap widget {
|
|
if {[$widget cget -wrap] eq "word"} {
|
|
$widget configure -wrap "none"
|
|
} else {
|
|
$widget configure -wrap "word"
|
|
}
|
|
}
|
|
|
|
proc full_screen window {
|
|
if {[wm attributes $window -fullscreen]} {
|
|
wm attributes $window -fullscreen 0
|
|
} else {
|
|
wm attributes $window -fullscreen 1
|
|
}
|
|
}
|
|
}
|
|
|
|
wm title . $window_title
|
|
option add *tearOff 0
|
|
. configure -padx 4
|
|
|
|
set icon_data "
|
|
iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAMAAAAoLQ9TAAAADFBMVEUAAAAbG29tXkfAox/rVIN+
|
|
AAAABHRSTlMA////sy1AiAAAAFNJREFUGNNtj4EOACEIQlX+/58PlNqtYrUSn6URVFox0rWoZSkE
|
|
wF3jZAKD6FRckIfG6DBYDBoRYKYRGtXLdZu4jF/J9ej5rRvL3Zhbdz5fwx3jf9s1AZwI7R6CAAAA
|
|
b2FsUGh42l3Pyw2AIBBF0bcBewEtVQPRaDF+mgALEVxi8BtlvCvOBEIGAApt19WqHFdZu8Wr0PCT
|
|
U3wbj0EXk2oUW+ogdSRVM7Xx1M5RL//7irrMA/lPoEmtAT587NmxAK+fJ0Gze0NZGe9NKc7zDvx4
|
|
xwbTZt61AAAAAElFTkSuQmCC
|
|
"
|
|
image create photo app_icon -data $icon_data
|
|
wm iconphoto . app_icon
|
|
|
|
if {[tk windowingsystem] == "x11"} {
|
|
ttk::style theme use "clam"
|
|
}
|
|
|
|
pack [ttk::frame .toolbar] -side top -pady 4
|
|
|
|
ttk::frame .status
|
|
ttk::label .status.line -relief sunken -textvar status
|
|
ttk::sizegrip .status.grip
|
|
|
|
pack .status -side bottom -fill x -pady 4
|
|
pack .status.line -side left -fill x -expand 1
|
|
pack .status.grip -side right -anchor s
|
|
|
|
ttk::panedwindow .workspace -orient horizontal
|
|
ttk::frame .workspace.edit
|
|
ttk::frame .workspace.view
|
|
.workspace add .workspace.edit -weight 1
|
|
.workspace add .workspace.view -weight 1
|
|
|
|
set editor [ctext .workspace.edit.text \
|
|
-width 40 -height 25 -wrap "word" -undo 1]
|
|
font_size::reset $editor
|
|
tk_util::pack_scrolled $editor
|
|
|
|
set preview [canvas .workspace.view.canvas]
|
|
pack $preview -side "left" -fill "both" -expand 1
|
|
|
|
pack .workspace -side top -fill both -expand 1
|
|
|
|
ttk::button .toolbar.new -text "New" -width 8 -under 0 -command do_new
|
|
ttk::button .toolbar.bOpen -text "Open" -width 8 -under 0 -command do_open
|
|
ttk::button .toolbar.save -text "Save" -width 8 -under 0 -command do_save
|
|
|
|
ttk::separator .toolbar.sep1 -orient vertical
|
|
|
|
ttk::button .toolbar.find -text "Find" -width 8 -under 0 -command do_find
|
|
ttk::button .toolbar.again -text "Again" -width 8 -under 1 -command find_again
|
|
|
|
ttk::separator .toolbar.sep2 -orient vertical
|
|
|
|
ttk::button .toolbar.render -text "Render" -width 8 -under 0 \
|
|
-command {do_render; do_preview}
|
|
ttk::button .toolbar.export -text "Export" -width 8 -under 0 -command do_export
|
|
ttk::button .toolbar.stats -text "Stats" -width 8 -under 1 -command show_stats
|
|
|
|
pack .toolbar.new -side left
|
|
pack .toolbar.bOpen -side left
|
|
pack .toolbar.save -side left
|
|
|
|
pack .toolbar.sep1 -side left -padx 4 -pady 4 -fill y
|
|
|
|
pack .toolbar.find -side left
|
|
pack .toolbar.again -side left
|
|
|
|
pack .toolbar.sep2 -side left -padx 4 -pady 4 -fill y
|
|
|
|
pack .toolbar.render -side left
|
|
pack .toolbar.export -side left
|
|
pack .toolbar.stats -side left
|
|
|
|
. configure -menu [menu .menubar]
|
|
|
|
set m [menu .menubar.mFile]
|
|
$m add command -label "New" -command do_new -under 0 -accel "Ctrl-N"
|
|
$m add command -label "Open..." -command do_open -under 0 -accel "Ctrl-O"
|
|
$m add command -label "Save" -command do_save -under 0 -accel "Ctrl-S"
|
|
$m add separator
|
|
$m add command -label "Save as..." -command do_save_as -under 5
|
|
$m add command -label "Reload" -command do_reload -under 0
|
|
$m add command -label "Statistics" -command show_stats -under 1 -accel "Ctrl-T"
|
|
$m add separator
|
|
$m add command -label "Quit" -command do_quit -under 0 -accel "Ctrl-Q"
|
|
.menubar add cascade -menu .menubar.mFile -label "File" -underline 0
|
|
|
|
set m [menu .menubar.edit]
|
|
$m add command -label "Undo" -command {$editor edit undo} \
|
|
-underline 0 -accelerator "Ctrl-Z"
|
|
$m add command -label "Redo" -command {$editor edit redo} \
|
|
-underline 0 -accelerator "Ctrl-Y"
|
|
$m add separator
|
|
$m add command -label "Cut" -command {tk_textCut $editor} \
|
|
-underline 0 -accelerator "Ctrl-X"
|
|
$m add command -label "Copy" -command {tk_textCopy $editor} \
|
|
-underline 1 -accelerator "Ctrl-C"
|
|
$m add command -label "Paste" -command {tk_util::paste_content $editor} \
|
|
-underline 0 -accelerator "Ctrl-V"
|
|
$m add separator
|
|
$m add command -label "Select all" -under 7 -accel "Ctrl-A" \
|
|
-command {tk_util::select_all $editor; break}
|
|
$m add command -label "Find..." -command do_find -under 0 -accel "Ctrl-F"
|
|
$m add command -label "Again" -command find_again -under 1 -accel "Ctrl-G"
|
|
.menubar add cascade -menu .menubar.edit -label "Edit" -underline 0
|
|
|
|
set m [menu .menubar.view]
|
|
$m add command -label "Render" -underline 0 -accelerator "F5" \
|
|
-command {do_render; do_preview}
|
|
$m add command -label "Export..." -command do_export \
|
|
-underline 0 -accelerator "Ctrl-E"
|
|
$m add separator
|
|
$m add checkbutton -label "Word wrap" -under 0 -var _word_wrap \
|
|
-command {tk_util::word_wrap $editor}
|
|
$m add checkbutton -label "Line numbers" -under 0 -var _line_nums \
|
|
-command {toggle_lines $editor}
|
|
$m add separator
|
|
$m add command -label "Bigger font" -under 0 -accel "Ctrl +" \
|
|
-command {font_size incr $editor}
|
|
$m add command -label "Smaller font" -under 0 -accel "Ctrl -" \
|
|
-command {font_size decr $editor}
|
|
$m add command -label "Reset font" -under 0 -accel "Ctrl-0" \
|
|
-command {font_size reset $editor}
|
|
$m add separator
|
|
$m add command -label "Color picker" -command pick_color \
|
|
-underline 9 -accelerator "Ctrl-K"
|
|
if {[llength [info commands "console"]] > 0} {
|
|
$m add command -label "Console" -command {console show} \
|
|
-underline 5 -accelerator "Ctrl-L"
|
|
}
|
|
$m add checkbutton -label "Full screen" -command {tk_util::full_screen .} \
|
|
-underline 10 -accelerator "F11" -var _full_screen
|
|
.menubar add cascade -menu .menubar.view -label "View" -underline 0
|
|
|
|
set m [menu .menubar.help]
|
|
$m add command -label "About" -command {alert $about_text} -under 0
|
|
$m add command -label "Credits" -command {alert $credits_text} -under 0
|
|
$m add command -label "Website" -command {open_in_app $site_link} -under 0
|
|
.menubar add cascade -menu .menubar.help -label "Help" -underline 0
|
|
|
|
wm protocol . WM_DELETE_WINDOW do_quit
|
|
bind $editor <<Modified>> show_modified
|
|
|
|
bind . <Control-n> do_new
|
|
bind . <Control-o> do_open
|
|
bind . <Control-s> do_save
|
|
bind . <Control-t> show_stats
|
|
bind . <Control-q> do_quit
|
|
|
|
bind . <Command-n> do_new
|
|
bind . <Command-o> do_open
|
|
bind . <Command-s> do_save
|
|
bind . <Command-t> show_stats
|
|
bind . <Command-q> do_quit
|
|
|
|
# Undo, cut and copy are already bound to their usual keys by default.
|
|
# Many bindings here have to override broken defaults.
|
|
|
|
bind $editor <Control-y> {$editor edit redo}
|
|
bind $editor <Control-v> {tk_util::paste_content $editor; break}
|
|
bind $editor <Control-a> {tk_util::select_all $editor; break}
|
|
bind . <Control-f> do_find
|
|
bind . <Control-g> find_again
|
|
|
|
bind $editor <Command-y> {$editor edit redo}
|
|
bind $editor <Command-v> {tk_util::paste_content $editor; break}
|
|
bind $editor <Command-a> {tk_util::select_all $editor; break}
|
|
bind . <Command-f> do_find
|
|
bind . <Command-g> find_again
|
|
|
|
bind Text <Control-o> {}
|
|
bind Text <Control-e> {}
|
|
|
|
bind . <Control-equal> {font_size::increase $editor}
|
|
bind . <Control-minus> {font_size::decrease $editor}
|
|
bind . <Control-Key-0> {font_size::reset $editor}
|
|
|
|
bind . <Command-equal> {font_size::increase $editor}
|
|
bind . <Command-minus> {font_size::decrease $editor}
|
|
bind . <Command-Key-0> {font_size::reset $editor}
|
|
|
|
bind . <F5> {do_render; do_preview}
|
|
bind . <Control-r> {do_render; do_preview}
|
|
bind . <Command-r> {do_render; do_preview}
|
|
bind . <Control-e> do_export
|
|
bind . <Command-e> do_export
|
|
bind . <Control-k> pick_color
|
|
bind . <Command-k> pick_color
|
|
|
|
bind . <F11> {tk_util::full_screen .}
|
|
|
|
if {[llength [info commands "console"]] > 0} {
|
|
bind . <Control-l> {console show}
|
|
bind . <Command-l> {console show}
|
|
}
|
|
|
|
ctext::addHighlightClass $editor statements blue \
|
|
"proc set incr if elseif else for foreach while switch break continue return repeat alert"
|
|
ctext::addHighlightClass $editor functions purple \
|
|
"expr list string length llength + - * / sin cos"
|
|
ctext::addHighlightClass $editor drawing purple \
|
|
"line box circle oval text polygon color fill width font size viewport"
|
|
ctext::addHighlightClassWithOnlyCharStart $editor variables fuchsia "\$"
|
|
ctext::addHighlightClassForSpecialChars $editor punctuation blue {[]{};}
|
|
ctext::addHighlightClassForRegexp $editor comments gray {#[^\n\r]*}
|
|
ctext::addHighlightClassForRegexp $editor numbers green {[0-9\.\-]+}
|
|
ctext::addHighlightClassForRegexp $editor strings green {".*?"}
|
|
|
|
proc show_modified {} {
|
|
global status editor
|
|
if {[$editor edit modified]} {
|
|
set status "(modified)"
|
|
}
|
|
}
|
|
|
|
proc do_new {} {
|
|
global status file_name editor window_title
|
|
|
|
if {[$editor edit modified]} {
|
|
set answer [tk_messageBox -parent . \
|
|
-type "yesno" -icon "question" \
|
|
-title $window_title \
|
|
-message "New file?" \
|
|
-detail "File is unsaved.\nStart another?"]
|
|
if {!$answer} {
|
|
set status "New file canceled."
|
|
return
|
|
}
|
|
}
|
|
wm title . $window_title
|
|
set file_name ""
|
|
$editor delete "1.0" "end"
|
|
$editor edit reset
|
|
$editor edit modified 0
|
|
clear_drawing
|
|
set status [clock format [clock seconds]]
|
|
}
|
|
|
|
proc do_open {} {
|
|
global status file_types file_name editor window_title
|
|
|
|
if {[$editor edit modified]} {
|
|
set answer [tk_messageBox -parent . \
|
|
-type "yesno" -icon "question" \
|
|
-title $window_title \
|
|
-message "Open another file?" \
|
|
-detail "File is unsaved.\nOpen another?"]
|
|
if {!$answer} {
|
|
set status "Opening canceled."
|
|
return
|
|
}
|
|
}
|
|
set choice [tk_getOpenFile -parent . \
|
|
-title "Open existing file" \
|
|
-initialdir [file_dir $file_name] \
|
|
-filetypes $file_types]
|
|
if {[string length $choice] == 0} {
|
|
set status "Opening canceled."
|
|
} elseif {![file isfile $choice]} {
|
|
tk_messageBox -parent . \
|
|
-type "ok" -icon "error" \
|
|
-title $window_title \
|
|
-message "Error opening file" \
|
|
-detail "File not found: $choice"
|
|
} elseif {[load_file $choice]} {
|
|
set file_name $choice
|
|
clear_drawing
|
|
}
|
|
}
|
|
|
|
proc load_file full_path {
|
|
global status editor window_title
|
|
|
|
set fn [file tail $full_path]
|
|
try {
|
|
set f [open $full_path]
|
|
tk_util::load_text $editor [read $f]
|
|
$editor highlight 1.0 end
|
|
set status "Opened $fn"
|
|
wm title . "$fn | $window_title"
|
|
return 1
|
|
} on error e {
|
|
tk_messageBox -parent . \
|
|
-type "ok" -icon "error" \
|
|
-title $window_title \
|
|
-message "Error opening file" \
|
|
-detail $e
|
|
return 0
|
|
} finally {
|
|
close $f
|
|
}
|
|
}
|
|
|
|
proc file_dir name {
|
|
if {$name ne ""} {
|
|
return [file dirname $name]
|
|
} else {
|
|
return [pwd]
|
|
}
|
|
}
|
|
|
|
proc do_save {} {
|
|
global file_name
|
|
if {$file_name eq ""} {
|
|
do_save_as
|
|
} else {
|
|
save_file $file_name
|
|
}
|
|
}
|
|
|
|
proc do_save_as {} {
|
|
global file_name file_types status
|
|
|
|
set choice [tk_getSaveFile -parent . \
|
|
-title "Save file as..." \
|
|
-initialdir [file_dir $file_name] \
|
|
-filetypes $file_types]
|
|
if {[string length $choice] == 0} {
|
|
set status "Save canceled."
|
|
} elseif {[save_file $choice]} {
|
|
set file_name $choice
|
|
}
|
|
}
|
|
|
|
proc save_file full_path {
|
|
global status editor window_title
|
|
|
|
set fn [file tail $full_path]
|
|
set data [$editor get "1.0" "end"]
|
|
set data [string trimright $data "\n"]
|
|
try {
|
|
set f [open $full_path "w"]
|
|
puts $f $data
|
|
flush $f
|
|
$editor edit modified 0
|
|
set status "Saved $fn"
|
|
wm title . "$fn | $window_title"
|
|
return 1
|
|
} on error e {
|
|
tk_messageBox -parent . \
|
|
-type "ok" -icon "error" \
|
|
-title $window_title \
|
|
-message "Error saving file" \
|
|
-detail $e
|
|
return 0
|
|
} finally {
|
|
close $f
|
|
}
|
|
}
|
|
|
|
proc do_reload {} {
|
|
global file_name status window_title
|
|
if {$file_name eq ""} {
|
|
tk_messageBox -parent . \
|
|
-type "ok" -icon "warning" \
|
|
-title $window_title \
|
|
-message "Can't reload." \
|
|
-detail "The file was never saved."
|
|
} else {
|
|
set answer [tk_messageBox -parent . \
|
|
-type "yesno" -icon "question" \
|
|
-title $window_title \
|
|
-message "Reload file?" \
|
|
-detail "Reload last save?"]
|
|
if {$answer eq "yes"} {
|
|
load_file $file_name
|
|
} else {
|
|
set status "Reloading canceled."
|
|
}
|
|
}
|
|
}
|
|
|
|
proc show_stats {} {
|
|
global editor d_list window_title
|
|
do_render
|
|
set data [$editor get "1.0" "end"]
|
|
set msg "Project statistics"
|
|
set clean [string trimright $data "\n"]
|
|
set lines [llength [split $clean "\n"]]
|
|
set shape [llength $d_list]
|
|
set stats "$lines lines of code\n$shape shapes defined"
|
|
tk_messageBox -parent . \
|
|
-type "ok" -icon "info" -title $window_title \
|
|
-message $msg -detail $stats
|
|
}
|
|
|
|
proc do_quit {} {
|
|
global editor window_title
|
|
if {[$editor edit modified]} {
|
|
set answer [tk_messageBox -parent . \
|
|
-type "yesno" -icon "question" \
|
|
-title $window_title \
|
|
-message "Quit Genoa?" \
|
|
-detail "File is unsaved.\nQuit anyway?"]
|
|
} else {
|
|
set answer "yes"
|
|
}
|
|
if {$answer eq "yes"} {
|
|
destroy .
|
|
}
|
|
}
|
|
|
|
proc do_find {} {
|
|
global search_term status editor
|
|
set term [tk_util::text_selection $editor]
|
|
set ret [tk_getString .gs answer "Search pattern:" \
|
|
-title "Find" -entryoptions "-textvar search_term"]
|
|
if {!$ret} {
|
|
set status "Search canceled."
|
|
return
|
|
}
|
|
set search_term $answer; # Possibly redundant
|
|
step_search
|
|
}
|
|
|
|
proc find_again {} {
|
|
global search_term status
|
|
if {$search_term eq ""} {
|
|
do_find
|
|
} else {
|
|
step_search
|
|
}
|
|
}
|
|
|
|
proc step_search {} {
|
|
global search_term status editor
|
|
set res [tk_util::highlight_text $editor $search_term "insert"]
|
|
if {$res eq ""} {
|
|
set search_term ""
|
|
set status "Nothing found."
|
|
}
|
|
}
|
|
|
|
proc reset_drawing {} {
|
|
global drawing
|
|
set drawing(color) "black"
|
|
set drawing(fill) ""
|
|
set drawing(font) "Times"
|
|
set drawing(size) "10"
|
|
set drawing(width) 1
|
|
set drawing(dash) ""
|
|
}
|
|
|
|
proc do_render {} {
|
|
global d_list editor window_title
|
|
|
|
reset_drawing
|
|
set d_list {}
|
|
|
|
try {
|
|
runner eval [$editor get 1.0 end]
|
|
} on error e {
|
|
tk_messageBox -parent . \
|
|
-type "ok" -icon "error" \
|
|
-title $window_title \
|
|
-message "Error in script" \
|
|
-detail $e
|
|
}
|
|
|
|
interp limit runner commands -value ""
|
|
interp limit runner commands -value 1000000
|
|
}
|
|
|
|
proc do_preview {} {
|
|
global d_list overlay preview
|
|
$preview delete all
|
|
foreach i $d_list {
|
|
shape2canvas $i $preview
|
|
}
|
|
$preview create rectangle $overlay -outline red -dash -
|
|
}
|
|
|
|
proc clear_drawing {} {
|
|
global d_list preview
|
|
set d_list {}
|
|
$preview delete all
|
|
}
|
|
|
|
proc shape2canvas {shape canvas} {
|
|
set coords [lmap i [dict get $shape coords] {int $i}]
|
|
switch [dict get $shape type] {
|
|
"line" {
|
|
set width [int [dict get $shape -width]]
|
|
set dash [lmap i [dict get $shape -dash] {int $i}]
|
|
$canvas create line $coords \
|
|
-width $width -dash $dash \
|
|
-fill [dict get $shape -outline]
|
|
}
|
|
"box" {
|
|
set width [int [dict get $shape -width]]
|
|
set dash [lmap i [dict get $shape -dash] {int $i}]
|
|
$canvas create rectangle $coords \
|
|
-width $width -dash $dash \
|
|
-outline [dict get $shape -outline] \
|
|
-fill [dict get $shape -fill]
|
|
}
|
|
"oval" {
|
|
set width [int [dict get $shape -width]]
|
|
set dash [lmap i [dict get $shape -dash] {int $i}]
|
|
$canvas create oval $coords \
|
|
-width $width -dash $dash \
|
|
-outline [dict get $shape -outline] \
|
|
-fill [dict get $shape -fill]
|
|
}
|
|
"text" {
|
|
$canvas create text $coords -anchor sw \
|
|
-text [dict get $shape -text] \
|
|
-font [dict get $shape -font] \
|
|
-fill [dict get $shape -fill]
|
|
}
|
|
"polygon" {
|
|
set width [int [dict get $shape -width]]
|
|
set dash [lmap i [dict get $shape -dash] {int $i}]
|
|
$canvas create polygon $coords \
|
|
-width $width -dash $dash \
|
|
-outline [dict get $shape -outline] \
|
|
-fill [dict get $shape -fill]
|
|
}
|
|
default { error "Unknown shape." }
|
|
}
|
|
}
|
|
|
|
proc do_export {} {
|
|
global file_name
|
|
set file_types {
|
|
{"SVG drawings" ".svg"}
|
|
{"All files" ".*"}
|
|
}
|
|
set fn [file tail $file_name]
|
|
set init [file rootname $fn]
|
|
set choice [tk_getSaveFile -parent . \
|
|
-title "Export file as..." \
|
|
-initialdir [file_dir $file_name] \
|
|
-initialfile "$init.svg" \
|
|
-filetypes $file_types]
|
|
if {$choice == ""} {
|
|
set status "Export canceled."
|
|
} else {
|
|
export_file $choice
|
|
}
|
|
}
|
|
|
|
proc export_file full_path {
|
|
global status d_list meta window_title
|
|
|
|
set fn [file tail $full_path]
|
|
try {
|
|
do_render
|
|
set f [open $full_path "w"]
|
|
puts $f "<svg xmlns='http://www.w3.org/2000/svg' width='$meta(width)' height='$meta(height)' viewBox='$meta(viewBox)'>"
|
|
foreach i $d_list {
|
|
puts $f [shape2svg $i]
|
|
}
|
|
puts $f "</svg>"
|
|
flush $f
|
|
set status "Exported $fn"
|
|
return 1
|
|
} on error e {
|
|
tk_messageBox -parent . \
|
|
-type "ok" -icon "error" \
|
|
-title $window_title \
|
|
-message "Export error" \
|
|
-detail $e
|
|
return 0
|
|
} finally {
|
|
close $f
|
|
}
|
|
}
|
|
|
|
proc shape2svg shape {
|
|
switch [dict get $shape type] {
|
|
"line" {
|
|
set stroke [dict get $shape -outline]
|
|
if {$stroke == ""} { set stroke "transparent" }
|
|
return "<line x1='[dict get $shape x1]' y1='[dict get $shape y1]' x2='[dict get $shape x2]' y2='[dict get $shape y2]' stroke='$stroke' stroke-width='[dict get $shape -width]' stroke-dasharray='[dict get $shape -dash]'/>"
|
|
}
|
|
"box" {
|
|
set fill [dict get $shape -fill]
|
|
if {$fill == ""} { set fill "transparent" }
|
|
set stroke [dict get $shape -outline]
|
|
if {$stroke == ""} { set stroke "transparent" }
|
|
return "<rect x='[dict get $shape x]' y='[dict get $shape y]' width='[dict get $shape width]' height='[dict get $shape height]' fill='$fill' stroke='[dict get $shape -outline]' stroke-width='[dict get $shape -width]' stroke-dasharray='[dict get $shape -dash]'/>"
|
|
}
|
|
"oval" {
|
|
set fill [dict get $shape -fill]
|
|
if {$fill == ""} { set fill "transparent" }
|
|
set stroke [dict get $shape -outline]
|
|
if {$stroke == ""} { set stroke "transparent" }
|
|
return "<ellipse cx='[dict get $shape cx]' cy='[dict get $shape cy]' rx='[dict get $shape rx]' ry='[dict get $shape ry]' fill='$fill' stroke='$stroke' stroke-width='[dict get $shape -width]' stroke-dasharray='[dict get $shape -dash]'/>"
|
|
}
|
|
"text" {
|
|
set fill [dict get $shape -fill]
|
|
if {$fill == ""} { set fill "transparent" }
|
|
set text [dict get $shape -text]
|
|
return "<text x='[dict get $shape x]' y='[dict get $shape y]' fill='$fill' font-family='[dict get $shape font-family]' font-size='[dict get $shape font-size]'>[escape $text]</text>"
|
|
}
|
|
"polygon" {
|
|
set fill [dict get $shape -fill]
|
|
if {$fill == ""} { set fill "transparent" }
|
|
set stroke [dict get $shape -outline]
|
|
if {$stroke == ""} { set stroke "transparent" }
|
|
return "<polygon points='[dict get $shape coords]' fill='$fill' stroke='[dict get $shape -outline]' stroke-width='[dict get $shape -width]' stroke-dasharray='[dict get $shape -dash]'/>"
|
|
}
|
|
default { error "Unknown shape." }
|
|
}
|
|
}
|
|
|
|
proc escape html {
|
|
set chars { < < > > \" " ' ' & & }
|
|
return [string map $chars $html]
|
|
}
|
|
|
|
proc toggle_lines widget {
|
|
if {[$widget cget -linemap]} {
|
|
$widget configure -linemap 0
|
|
} else {
|
|
$widget configure -linemap 1
|
|
}
|
|
}
|
|
|
|
proc pick_color {} {
|
|
global window_title drawing editor
|
|
set choice [tk_chooseColor -parent . \
|
|
-title $window_title \
|
|
-initialcolor $drawing(color)]
|
|
$editor insert "insert" \"$choice\"
|
|
}
|
|
|
|
proc alert message {
|
|
global window_title
|
|
tk_messageBox -parent . \
|
|
-type "ok" -icon "info" \
|
|
-title $window_title \
|
|
-message $message
|
|
}
|
|
|
|
proc open_in_app link {
|
|
global status
|
|
if {[auto_execok "xdg-open"] ne ""} {
|
|
catch {exec "xdg-open" $link &}
|
|
} elseif {[auto_execok "open"] ne ""} {
|
|
catch {exec "open" $link &}
|
|
} elseif {[auto_execok "start"] ne ""} {
|
|
catch {exec "start" $link &}
|
|
} else {
|
|
set status "Can't open website."
|
|
}
|
|
}
|
|
|
|
set status [clock format [clock seconds]]
|
|
|
|
if {[llength $argv] > 0} {
|
|
set fn [lindex $argv 0]
|
|
if {![file exists $fn]} {
|
|
set file_name [file normalize $fn]
|
|
set fn [file tail $file_name]
|
|
wm title . "$fn | $window_title"
|
|
} elseif {[load_file $fn]} {
|
|
set file_name [file normalize $fn]
|
|
}
|
|
}
|