Add initial release
This commit is contained in:
parent
872c0ccd48
commit
cf4b055749
5
NEWS.md
Normal file
5
NEWS.md
Normal file
|
|
@ -0,0 +1,5 @@
|
|||
# Genoa Banner Creator project news
|
||||
|
||||
## [0.3 alpha] - 2023-09-09
|
||||
|
||||
Initial release
|
||||
53
README.md
53
README.md
|
|
@ -1,3 +1,52 @@
|
|||
# genoa
|
||||
# Intro to Genoa Banner Creator
|
||||
|
||||
a tool to generate original art
|
||||
This is yet another experimental tool for procedural art. Use simple scripts to describe graphical banners and posters with many repetitive elements, then export them as SVG for further use. Scripts can be edited and previewed in place for rapid turnaround.
|
||||
|
||||
Rationale: I make vector art by hand (see the Pocket Guide to Writing SVG, by Joni Trythall). It's a wonderful artistic medium, but turnaround can be slow between my text editor and image viewer. Also, that way it's hard to add repetitive elements. Genoa is meant to help with that as a first step, and for quick iteration of ideas.
|
||||
|
||||
## Availability
|
||||
|
||||
As of September 2023, Genoa is at a very early alpha stage: incomplete, undocumented and probably buggy. Use at your own risk. System requirements:
|
||||
|
||||
- Tcl/Tk 8.6 with tklib
|
||||
- screen resolution:
|
||||
- minimum 800x600
|
||||
- recommended 1280x800
|
||||
|
||||
## Usage
|
||||
|
||||
Genoa is powered by a little language based on Tcl. Right now it can generate its own promotional banner, like this:
|
||||
|
||||
```tcl
|
||||
# The viewport declaration can be anywhere.
|
||||
viewport 75 50 630 500
|
||||
|
||||
width 0
|
||||
fill darkslategray
|
||||
box 75 50 630 500
|
||||
width 10
|
||||
fill ""
|
||||
|
||||
proc circles {cx cy} {
|
||||
repeat 10 {
|
||||
incr i 30
|
||||
circle $cx $cy $i
|
||||
}
|
||||
}
|
||||
color darkred; circles 200 200
|
||||
color green; circles 500 100
|
||||
color darkblue; circles 400 400
|
||||
|
||||
font "Noto Sans"; size 48
|
||||
color white; set j 0
|
||||
foreach i {GENERATE ORIGINAL ART} {
|
||||
incr j 64
|
||||
text 225 [+ 225 $j] $i
|
||||
}
|
||||
```
|
||||
|
||||
Simply paste it in then hit Preview and/or Export. No need to save first.
|
||||
|
||||
## License and contact
|
||||
|
||||
Genoa is open source under the MIT License. Feedback is welcome. I can be found most readily as @notimetoplay@elekk.xyz on Mastodon, or else in the #ctrl-c channel of tilde.chat (on IRC).
|
||||
|
|
|
|||
25
banner.tcl
Normal file
25
banner.tcl
Normal file
|
|
@ -0,0 +1,25 @@
|
|||
# The viewport declaration can be anywhere.
|
||||
viewport 75 50 630 500
|
||||
|
||||
width 0
|
||||
fill darkslategray
|
||||
box 75 50 630 500
|
||||
width 10
|
||||
fill ""
|
||||
|
||||
proc circles {cx cy} {
|
||||
repeat 10 {
|
||||
incr i 30
|
||||
circle $cx $cy $i
|
||||
}
|
||||
}
|
||||
color darkred; circles 200 200
|
||||
color green; circles 500 100
|
||||
color darkblue; circles 400 400
|
||||
|
||||
font "Noto Sans"; size 48
|
||||
color white; set j 0
|
||||
foreach i {GENERATE ORIGINAL ART} {
|
||||
incr j 64
|
||||
text 225 [+ 225 $j] $i
|
||||
}
|
||||
835
genoa.tcl
Normal file
835
genoa.tcl
Normal file
|
|
@ -0,0 +1,835 @@
|
|||
#!/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 getstring
|
||||
namespace import getstring::*
|
||||
|
||||
set window_title "Genoa Banner Creator"
|
||||
|
||||
set about_text "Tool to Generate Original Art\nv0.3 alpha (8 Sep 2023)"
|
||||
set credits_text "Made by No Time To Play\nMIT License"
|
||||
set site_link "https://notimetoplay.org/"
|
||||
|
||||
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 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
|
||||
|
||||
runner eval {
|
||||
proc repeat {times code} {
|
||||
for {set i 0} {$i < $times} {incr i} {
|
||||
uplevel 1 $code
|
||||
}
|
||||
}
|
||||
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)]
|
||||
}
|
||||
|
||||
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)]
|
||||
}
|
||||
|
||||
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)]
|
||||
}
|
||||
|
||||
proc oval {cx cy r1 r2} {
|
||||
global d_list drawing
|
||||
set coords [list [- $cx $r1] [- $cy $r2] [+ $cx $r1] [+ $cy $r2]]
|
||||
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)]
|
||||
}
|
||||
|
||||
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 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 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 color color
|
||||
runner alias fill fill
|
||||
runner alias width width
|
||||
runner alias font set_font
|
||||
runner alias size size
|
||||
runner alias viewport viewport
|
||||
|
||||
set file_types {
|
||||
{"Genoa scripts" ".tcl"}
|
||||
{"All files" ".*"}
|
||||
}
|
||||
|
||||
set file_name ""
|
||||
set search_term ""
|
||||
set _word_wrap 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 open_line widget {
|
||||
$widget insert "insert +0 chars" "\n"
|
||||
$widget mark set "insert" "insert -1 chars"
|
||||
}
|
||||
|
||||
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
|
||||
|
||||
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 [text .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 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
|
||||
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 . <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 . <F11> {tk_util::full_screen .}
|
||||
|
||||
if {[llength [info commands "console"]] > 0} {
|
||||
bind . <Control-l> {console show}
|
||||
bind . <Command-l> {console show}
|
||||
}
|
||||
|
||||
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
|
||||
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
|
||||
}
|
||||
}
|
||||
|
||||
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]
|
||||
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 do_render {} {
|
||||
global d_list editor window_title
|
||||
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
|
||||
}
|
||||
}
|
||||
|
||||
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 shape2canvas {shape canvas} {
|
||||
switch [dict get $shape type] {
|
||||
"line" {
|
||||
$canvas create line [dict get $shape coords] \
|
||||
-fill [dict get $shape -outline] \
|
||||
-width [dict get $shape -width]
|
||||
}
|
||||
"box" {
|
||||
$canvas create rectangle \
|
||||
[dict get $shape coords] \
|
||||
-outline [dict get $shape -outline] \
|
||||
-width [dict get $shape -width] \
|
||||
-fill [dict get $shape -fill]
|
||||
}
|
||||
"oval" {
|
||||
$canvas create oval [dict get $shape coords] \
|
||||
-outline [dict get $shape -outline] \
|
||||
-width [dict get $shape -width] \
|
||||
-fill [dict get $shape -fill]
|
||||
}
|
||||
"text" {
|
||||
$canvas create text [dict get $shape coords] \
|
||||
-text [dict get $shape -text] \
|
||||
-font [dict get $shape -font] \
|
||||
-fill [dict get $shape -fill] \
|
||||
-anchor sw
|
||||
}
|
||||
default { error "Unknown shape." }
|
||||
}
|
||||
}
|
||||
|
||||
proc do_export {} {
|
||||
global file_name
|
||||
set file_types {
|
||||
{"SVG drawings" ".svg"}
|
||||
{"All files" ".*"}
|
||||
}
|
||||
set choice [tk_getSaveFile -parent . \
|
||||
-title "Export file as..." \
|
||||
-initialdir [file_dir $file_name] \
|
||||
-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]'/>"
|
||||
}
|
||||
"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]'/>"
|
||||
}
|
||||
"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]'/>"
|
||||
}
|
||||
"text" {
|
||||
set fill [dict get $shape -fill]
|
||||
if {$fill == ""} { set fill "transparent" }
|
||||
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]'>[dict get $shape -text]</text>"
|
||||
}
|
||||
default { error "Unknown shape." }
|
||||
}
|
||||
}
|
||||
|
||||
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 | Genoa"
|
||||
} elseif {[load_file $fn]} {
|
||||
set file_name [file normalize $fn]
|
||||
}
|
||||
}
|
||||
Loading…
Reference in New Issue
Block a user