20 changed files with 1629 additions and 68 deletions
@ -0,0 +1,575 @@
|
||||
#! /usr/bin/env tclsh |
||||
# The game 2048 implemented in Tcl. |
||||
# Version 1.0.0. |
||||
# |
||||
# This code is released under the terms of the MIT license. |
||||
# See the file LICENSE for details. |
||||
# |
||||
# More at: |
||||
# - https://github.com/dbohdan/2048.tcl -- Git repository |
||||
# - https://wiki.tcl-lang.org/40557 -- discussion |
||||
|
||||
package require Tcl 8.6 9 |
||||
|
||||
namespace eval 2048 { |
||||
namespace ensemble create |
||||
namespace export * |
||||
|
||||
# Utility procs. |
||||
|
||||
proc vars args { |
||||
foreach varname $args { |
||||
uplevel [list variable $varname] |
||||
} |
||||
} |
||||
|
||||
# Pick a random item from the given list. |
||||
proc pick list { |
||||
lindex $list [expr {int(rand() * [llength $list])}] |
||||
} |
||||
|
||||
# An abstraction representing the game board. Operates at the level of cells |
||||
# containing numerical values, not movable game tiles. |
||||
namespace eval board { |
||||
namespace ensemble create |
||||
namespace export * |
||||
|
||||
variable data {} |
||||
variable size 0 |
||||
|
||||
# Iterate over every cell of the game board and run $script for each. |
||||
# |
||||
# The game board is a 2D matrix of a fixed size that consists of |
||||
# elements called "cells" that each can contain a number. |
||||
# |
||||
# - $cellList is a list of cell indexes (coordinates), which are |
||||
# themselves lists of two numbers each. They each represent the location |
||||
# of a given cell on the board. |
||||
# - $varName1 and $varName2 are the names of the variables that will be |
||||
# assigned the current cell's indexes when running the script. |
||||
# - $cellVarName is the name of the variable that at each step will |
||||
# contain the numerical value of the current cell. Assigning to it |
||||
# will change the cell's value. |
||||
# - $script is the script to run. |
||||
proc forcells {cellList varName1 varName2 cellVarName script} { |
||||
upvar $varName1 i |
||||
upvar $varName2 j |
||||
upvar $cellVarName c |
||||
foreach cell $cellList { |
||||
lassign $cell i j |
||||
set c [get-cell $cell] |
||||
|
||||
try { |
||||
uplevel $script |
||||
} on ok {res opts} - \ |
||||
on error {res opts} - \ |
||||
on break {res opts} - \ |
||||
on continue {res opts} { |
||||
return -options $opts $res |
||||
} on return {res opts} { |
||||
return -options [dict replace $opts -level 2] $res |
||||
} |
||||
|
||||
set-cell [list $i $j] $c |
||||
} |
||||
} |
||||
|
||||
# Generate a list of cell indexes for every cell of the board. The order |
||||
# in which the cell indexes appear depends on the value of |
||||
# $directionVect. E.g., if $directionVect is {1 1} the list will be |
||||
# {{0 0} {0 1} ... {0 size-1} {1 0} {1 1} ... {size-1 size-1}} |
||||
proc indexes {{directionVect {1 1}}} { |
||||
variable size |
||||
|
||||
lassign $directionVect delta(i) delta(j) |
||||
foreach varName {i j} { |
||||
switch -exact -- $delta($varName) { |
||||
1 { |
||||
set start($varName) 0 |
||||
set end($varName) $size |
||||
} |
||||
-1 { |
||||
set start($varName) [expr {$size - 1}] |
||||
set end($varName) -1 |
||||
} |
||||
default { |
||||
error "direction vector must be {?-?1 ?-?1}" |
||||
} |
||||
} |
||||
} |
||||
|
||||
set list {} |
||||
for {set i $start(i)} {$i != $end(i)} {incr i $delta(i)} { |
||||
for {set j $start(j)} {$j != $end(j)} {incr j $delta(j)} { |
||||
lappend list [list $i $j] |
||||
} |
||||
} |
||||
return $list |
||||
} |
||||
|
||||
# Check if the list $cell represents a valid pair of cell coordinates. |
||||
proc valid-cell? cell { |
||||
variable size |
||||
lassign $cell i j |
||||
return [expr {(0 <= $i) && ($i < $size) && |
||||
(0 <= $j) && ($j < $size)}] |
||||
} |
||||
|
||||
# Prepare the board for use. Must be called before any other board |
||||
# procs. |
||||
proc init boardSize { |
||||
variable data |
||||
variable size |
||||
set size $boardSize |
||||
for {set i 0} {$i < $size} {incr i} { |
||||
for {set j 0} {$j < $size} {incr j} { |
||||
set-cell [list $i $j] 0 |
||||
} |
||||
} |
||||
} |
||||
|
||||
# Get the value of a game board cell. |
||||
proc get-cell cell { |
||||
variable data |
||||
dict get $data $cell |
||||
} |
||||
|
||||
# Set the value of a game board cell. |
||||
proc set-cell {cell value} { |
||||
variable data |
||||
dict set data $cell $value |
||||
} |
||||
|
||||
# Filter the list of board cell indexes $cellList to only have those |
||||
# indexes that correspond to empty board cells. |
||||
proc empty cellList { |
||||
set resultList {} |
||||
foreach cell $cellList { |
||||
if {[get-cell $cell] == 0} { |
||||
lappend resultList $cell |
||||
} |
||||
} |
||||
return $resultList |
||||
} |
||||
|
||||
# Pretty-print the board. Specify an index in $highlight to highlight a |
||||
# cell with a "*" after its contents. |
||||
proc print {{highlight {-1 -1}}} { |
||||
forcells [indexes] i j cell { |
||||
if {$j == 0} { |
||||
append res \n |
||||
} |
||||
append res [ |
||||
if {$cell != 0} { |
||||
if {($i == [lindex $highlight 0]) && |
||||
($j == [lindex $highlight 1])} { |
||||
format {[%3s*]} $cell |
||||
} else { |
||||
format {[%4s]} $cell |
||||
} |
||||
} else { |
||||
lindex "......" |
||||
} |
||||
] |
||||
} |
||||
append res \n |
||||
} |
||||
} ;# namespace board |
||||
|
||||
# Game logic. |
||||
namespace eval game-logic { |
||||
namespace ensemble create |
||||
namespace export * |
||||
} |
||||
|
||||
# Put a "2" into an empty cell on the board. |
||||
proc spawn-new-tile {} { |
||||
set emptyCell [pick [board empty [board indexes]]] |
||||
if {[llength $emptyCell] > 0} { |
||||
board set-cell $emptyCell 2 |
||||
} |
||||
return $emptyCell |
||||
} |
||||
|
||||
# If $checkOnly is false try to shift all cells one step in the direction of |
||||
# $directionVect. If $checkOnly is true just say if that move is possible. |
||||
proc move-all-tiles {directionVect {checkOnly 0}} { |
||||
set changedCells 0 |
||||
lassign $directionVect di dj |
||||
|
||||
# Traverse the board in such a way that those tiles that are closer to |
||||
# the edges are merged first. |
||||
set indexDirVect [list \ |
||||
[expr {$di == 0 ? 1 : -$di}] [expr {$dj == 0 ? 1 : -$dj}]] |
||||
board forcells [board indexes $indexDirVect] i j cell { |
||||
set newIndex [list [expr {$i + $di}] [expr {$j + $dj}]] |
||||
set removedStar 0 |
||||
|
||||
# For every nonempty source cell and valid destination cell... |
||||
if {$cell != 0 && [board valid-cell? $newIndex]} { |
||||
if {[board get-cell $newIndex] == 0} { |
||||
# The destination is empty. |
||||
if {$checkOnly} { |
||||
return true |
||||
} else { |
||||
# Move the tile to the empty cell. |
||||
board set-cell $newIndex $cell |
||||
set cell 0 |
||||
incr changedCells |
||||
} |
||||
} elseif {([board get-cell $newIndex] eq $cell) && |
||||
[string first + $cell] == -1} { |
||||
# The destination is the same number as the source. |
||||
if {$checkOnly} { |
||||
return -level 2 true |
||||
} else { |
||||
# When merging two tiles into one, mark the new tile |
||||
# with the marker of "+" to ensure it doesn't get |
||||
# combined again this turn. |
||||
board set-cell $newIndex [expr {2 * $cell}]+ |
||||
set cell 0 |
||||
incr changedCells |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {$checkOnly} { |
||||
return false |
||||
} |
||||
|
||||
# Remove "changed this turn" markers at the end of the turn. |
||||
if {$changedCells == 0} { |
||||
board forcells [board indexes] i j cell { |
||||
set cell [string trim $cell +] |
||||
} |
||||
} |
||||
return $changedCells |
||||
} |
||||
|
||||
# Return the sum of the numbers on all tiles. |
||||
proc score {} { |
||||
set score 0 |
||||
board forcells [board indexes] i j cell { |
||||
incr score $cell |
||||
} |
||||
return $score |
||||
} |
||||
|
||||
# Is it possible to move any tiles in the direction of $directionVect? |
||||
proc can-move? directionVect { |
||||
move-all-tiles $directionVect 1 |
||||
} |
||||
|
||||
# Check the win condition. The player wins when there is a 2048 tile. |
||||
proc check-win {} { |
||||
board forcells [board indexes] i j cell { |
||||
if {$cell == 2048} { |
||||
variable output "You win!\n" |
||||
quit-game 0 |
||||
} |
||||
} |
||||
} |
||||
|
||||
# Check the lose condition. The player loses when the win condition isn't |
||||
# met and there are no possible moves. |
||||
proc check-lose possibleMoves { |
||||
# If not all board cells are empty and no possible moves remain... |
||||
if {![llength $possibleMoves] && |
||||
([board empty [board indexes]] ne [board indexes])} { |
||||
variable output "You lose.\n" |
||||
quit-game 0 |
||||
} |
||||
} |
||||
|
||||
# Exit the game with an exit status. |
||||
proc quit-game status { |
||||
vars done inputMethod inputModeSaved output playing stty_save turns |
||||
|
||||
if [info exists output] { |
||||
puts $output[set output {}] |
||||
|
||||
# Print the total number of turns played. |
||||
set turnsMessage [list $turns turn] |
||||
if {($turns % 10 != 1) || ($turns % 100 == 11)} { |
||||
append turnsMessage s |
||||
} |
||||
puts "$turnsMessage. [score] points." |
||||
} |
||||
|
||||
switch $inputMethod { |
||||
twapi { |
||||
twapi::modify_console_input_mode stdin {*}$inputModeSaved |
||||
} |
||||
raw { |
||||
if {$inputModeSaved ne {}} { |
||||
exec stty $inputModeSaved 2>@stderr |
||||
} |
||||
} |
||||
} |
||||
set done $status |
||||
exit $status |
||||
} |
||||
|
||||
# Event-driven input. Called when the player pressed a key. |
||||
proc input {} { |
||||
vars inputMethod output playing |
||||
variable playerInput [read stdin 1] |
||||
if {[set charcode [scan $playerInput %c]] in [list 10 {}]} { |
||||
if {$charcode eq 10 && $inputMethod ne {}} { |
||||
#this only happens in raw/twapi mode. add a newline to stdout |
||||
append output \n |
||||
} |
||||
set playerInput {} |
||||
} |
||||
after cancel $playing |
||||
play-user |
||||
} |
||||
|
||||
# Process the user input at the start of the game or during play. |
||||
proc play-user {} { |
||||
vars controls inputMethod output playerInput playerMove \ |
||||
playType possibleMoves preferences size |
||||
|
||||
if {!$size} { |
||||
# The game is starting. |
||||
set size $playerInput |
||||
# Handle zero, one and non-digit input. |
||||
if {$size eq "q"} { |
||||
quit-game 0 |
||||
} |
||||
if {![string is digit $size] || $size == 1} { |
||||
set size 0 |
||||
} |
||||
if {$size == 0} { |
||||
return |
||||
} |
||||
# Choose the default size on <enter>. |
||||
if {$size eq {}} { |
||||
set size 4 |
||||
} |
||||
# Generate an empty board of a given size. |
||||
board init $size |
||||
|
||||
after idle [namespace code start-turn] |
||||
return |
||||
} |
||||
|
||||
switch [scan $playerInput %c] { |
||||
3 { |
||||
if {$playType eq {random}} { |
||||
set playType user |
||||
} else { |
||||
quit-game 0 |
||||
} |
||||
} |
||||
} |
||||
if {[dict exists $preferences $playerInput]} { |
||||
switch $playerInput { |
||||
q { |
||||
quit-game 0 |
||||
} |
||||
r { |
||||
set playType random |
||||
after idle [namespace code {play-random 0}] |
||||
return |
||||
} |
||||
R { |
||||
set playType random |
||||
after idle [namespace code {play-random 1}] |
||||
return |
||||
} |
||||
s { |
||||
append output "Score: [score]\n" |
||||
} |
||||
? { |
||||
proc print-msg dictionary { |
||||
upvar 1 output output |
||||
foreach {key message} $dictionary { |
||||
append output "$key: $message\n" |
||||
} |
||||
} |
||||
append output \ |
||||
"[join [dict keys $controls] {, }]: movement\n" |
||||
print-msg $preferences |
||||
} |
||||
} |
||||
} elseif {$playerInput in $possibleMoves} { |
||||
set playerMove [dict get $controls $playerInput] |
||||
} |
||||
complete-turn |
||||
} |
||||
|
||||
# Set the user input to a random possible move. |
||||
proc play-random {continuous} { |
||||
vars controls playing playerInput possibleMoves |
||||
variable delay 1000 |
||||
set playerInput [pick $possibleMoves] |
||||
play-user |
||||
if {$continuous} { |
||||
set playing [after $delay [namespace code {play-random 1}]] |
||||
} |
||||
} |
||||
|
||||
# Apply the player's move, if any, and increment the turn counter. |
||||
proc complete-turn {} { |
||||
vars playerMove turns |
||||
if {$playerMove eq {}} { |
||||
flush stdout |
||||
start-turn 0 |
||||
} else { |
||||
incr turns |
||||
# Apply the current move until no changes occur on the board. |
||||
while true { |
||||
if {[move-all-tiles $playerMove] == 0} break |
||||
} |
||||
start-turn |
||||
} |
||||
} |
||||
|
||||
# Render board, find possible moves, add new tile, check win/lose. |
||||
proc start-turn {{makeNewTile 1}} { |
||||
vars controls inputMethod output ingame newTile |
||||
variable playerMove {} |
||||
variable possibleMoves {} |
||||
# Buffer the output to speed up the rending on slower terminals. |
||||
if {!$ingame} { |
||||
puts {Press "?" at any time after entering the board size for help.} |
||||
puts {Press "q" to quit.} |
||||
puts {Select board size (4)} |
||||
set ingame 1 |
||||
return |
||||
} |
||||
|
||||
switch $inputMethod { |
||||
twapi { |
||||
twapi::clear_console stdout |
||||
twapi::set_console_cursor_position stdout {0 0} |
||||
} |
||||
raw { |
||||
::term::ansi::send::clear |
||||
} |
||||
} |
||||
|
||||
# Add a new tile to the board and print the board highlighting that |
||||
# tile. |
||||
if {$makeNewTile} { |
||||
set newTile [spawn-new-tile] |
||||
} elseif {![info exists newTile]} { |
||||
set newTile {} |
||||
} |
||||
append output \n[board print {*}[list $newTile]] |
||||
check-win |
||||
|
||||
# Find the possible moves. |
||||
foreach {button vector} $controls { |
||||
if {[can-move? $vector]} { |
||||
lappend possibleMoves $button |
||||
} |
||||
} |
||||
check-lose $possibleMoves |
||||
|
||||
append output "\nMove (" |
||||
foreach {button vector} $controls { |
||||
if {$button in $possibleMoves} { |
||||
append output $button |
||||
} |
||||
} |
||||
append output {)? } |
||||
puts -nonewline $output[set output {}] |
||||
flush stdout |
||||
} |
||||
|
||||
# Set up the game board and the controls. |
||||
proc init {} { |
||||
# Board size. |
||||
variable size 0 |
||||
variable playmode play-user |
||||
variable cell |
||||
variable delay 0 |
||||
variable ingame 0 |
||||
variable playing {} |
||||
variable playType user |
||||
variable turns 0 |
||||
|
||||
variable inputModeSaved {} |
||||
variable inputMethod {} |
||||
chan configure stdin -blocking 0 |
||||
|
||||
try { |
||||
package require twapi |
||||
|
||||
set inputModeSaved [twapi::get_console_input_mode stdin] |
||||
twapi::modify_console_input_mode stdin -lineinput false \ |
||||
-echoinput false |
||||
set inputMethod twapi |
||||
} on error _ { |
||||
catch { |
||||
set inputModeSaved [exec stty -g 2>@stderr] |
||||
# TODO: Find other ways to save the state of the |
||||
# terminal. |
||||
|
||||
package require term::ansi::ctrl::unix |
||||
package require term::ansi::send |
||||
term::ansi::ctrl::unix::raw |
||||
set inputMethod raw |
||||
} |
||||
} |
||||
|
||||
variable controls { |
||||
h {0 -1} |
||||
j {1 0} |
||||
k {-1 0} |
||||
l {0 1} |
||||
} |
||||
|
||||
variable preferences { |
||||
q quit |
||||
r {random move} |
||||
R {automatic random play (input anything to stop)} |
||||
s {show score} |
||||
? help |
||||
} |
||||
|
||||
start-turn |
||||
chan event stdin readable [namespace code input] |
||||
} |
||||
|
||||
proc main {} { |
||||
variable done |
||||
interp bgerror {} [namespace code bgerror] |
||||
after idle [namespace code init] |
||||
vwait done |
||||
exit $done |
||||
} |
||||
|
||||
# Output error and quit. |
||||
proc bgerror args { |
||||
puts stderr $::errorInfo |
||||
quit-game 1 |
||||
} |
||||
} |
||||
|
||||
# Check if we were run as the primary script by the interpreter. |
||||
# From https://wiki.tcl-lang.org/40097. |
||||
proc main-script? {} { |
||||
global argv0 |
||||
if {[info exists argv0] && [file exists [info script]] && |
||||
[file exists $argv0]} { |
||||
file stat $argv0 argv0Info |
||||
file stat [info script] scriptInfo |
||||
|
||||
# Adjust for running from a network drive on Windows. |
||||
package require platform |
||||
set platform [::platform::generic] |
||||
set windows [string match *win* $platform] |
||||
expr {($argv0Info(dev) == $scriptInfo(dev)) && |
||||
($windows || ($argv0Info(ino) == $scriptInfo(ino)))} |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
|
||||
if {[main-script?]} { |
||||
2048 main |
||||
} |
||||
@ -0,0 +1,798 @@
|
||||
#! /usr/bin/env tclsh |
||||
########################################################### |
||||
# Name: aloupe.tcl |
||||
# Author: Alex Plotnikov (aplsimple@gmail.com) |
||||
# Date: Feb 26, 2021 |
||||
# Brief: Handles a screen loupe. |
||||
# License: MIT. |
||||
########################################################### |
||||
|
||||
# _________________________ aloupe ________________________ # |
||||
|
||||
package require Tk |
||||
|
||||
package provide aloupe 1.8.2 |
||||
|
||||
namespace eval ::aloupe { |
||||
variable solo [expr {[info exist ::argv0] && [file normalize $::argv0] eq [file normalize [info script]]}] |
||||
} |
||||
if {$::aloupe::solo} {wm withdraw .} |
||||
|
||||
# _____ Remove installed (perhaps) packages used here _____ # |
||||
|
||||
if {$::aloupe::solo} { |
||||
foreach _ {apave baltip bartabs hl_tcl ttk::theme::awlight ttk::theme::awdark awthemes} { |
||||
set __ [package version $_] |
||||
catch { |
||||
package forget $_ |
||||
namespace delete ::$_ |
||||
puts "aloupe: clearing $_ $__" |
||||
} |
||||
unset __ |
||||
} |
||||
|
||||
# use TCLLIBPATH variable (some tclkits don't see it) |
||||
catch { |
||||
foreach _apave_ [lreverse $::env(TCLLIBPATH)] { |
||||
set _apave_ [file normalize $_apave_] |
||||
if {[lsearch -exact $::auto_path $_apave_]<0 && [file exists $_apave_]} { |
||||
set ::auto_path [linsert $::auto_path 0 $_apave_] |
||||
} |
||||
} |
||||
unset _apave_ |
||||
} |
||||
} |
||||
|
||||
# ________________________ Run solo at need _________________________ # |
||||
|
||||
proc ::aloupe::RunSolo {} { |
||||
# Runs aloupe as a sole Tcl script. |
||||
# When aloupe runs from tclkit, it may fail. So try it with tclsh deployed. |
||||
|
||||
set tclsh [auto_execok tclsh] |
||||
set tclexe [info nameofexecutable] |
||||
# tclsh may be sort of "tcl.sh" to run a tclkit |
||||
if {[file exists $tclsh] && [file size $tclsh]>1024 && $tclsh ne $tclexe} { |
||||
if {$::aloupe::solo} {set aar $::argv} {set aar {}} |
||||
exec -- $tclsh $::aloupe::aloupescript {*}$aar & |
||||
} else { |
||||
puts "aloupe error: $::aloupe::runerr" |
||||
tk_messageBox -title Error -icon error -message \ |
||||
"aloupe error:\n\ |
||||
\n$::aloupe::runerr\n\ |
||||
\nProbably, you need to install\ |
||||
\nTk packages treectrl and Img\ |
||||
\nwhose libraries may be named\ |
||||
\n'tktreectrl' and 'libtk-img'." |
||||
} |
||||
} |
||||
|
||||
proc ::aloupe::GetPackages {{dir .}} { |
||||
# Gets required packages. |
||||
# dir - supposed directory of packages |
||||
|
||||
set dir [file normalize $dir] |
||||
set dir1 [lindex [glob -nocomplain [file join $dir treectrl*]] 0] |
||||
if {[info exists ::auto_path] && $dir1 ne {}} { |
||||
set dir2 [lindex [glob -nocomplain [file join $dir Img1.*]] 0] |
||||
if {$dir2 ne {}} {lappend ::auto_path $dir1 $dir2} |
||||
} |
||||
return [catch {package require treectrl; package require Img} ::aloupe::runerr] |
||||
} |
||||
|
||||
proc ::aloupe::FindPackages {} { |
||||
# Tries to find required packages in an upper bin directory. |
||||
|
||||
set dirs [file split [file dirname [file normalize $::aloupe::aloupescript]]] |
||||
while 1 { |
||||
set dir [file join {*}$dirs bin] |
||||
if {[file exists $dir]} { |
||||
if {![set ::aloupe::starterr [::aloupe::GetPackages $dir]]} { |
||||
return yes |
||||
} |
||||
} |
||||
if {[set dirs [lreplace $dirs end end]] eq {}} break |
||||
} |
||||
return no |
||||
} |
||||
|
||||
set ::aloupe::aloupescript [info script] |
||||
set ::aloupe::starterr [::aloupe::GetPackages] |
||||
if {$::aloupe::solo && $::aloupe::starterr && ![::aloupe::FindPackages]} { |
||||
::aloupe::RunSolo |
||||
exit |
||||
} |
||||
|
||||
# ________________________ Variables _________________________ # |
||||
|
||||
::msgcat::mcload [file join [file dirname [info script]] msgs] |
||||
|
||||
namespace eval ::aloupe { |
||||
variable filename {} |
||||
namespace eval my { |
||||
variable HOMEDIR ~ |
||||
if {[info exists ::env(HOME)]} {set HOMEDIR $::env(HOME)} |
||||
variable size 26 |
||||
variable zoom 8 |
||||
variable pause 0 |
||||
variable data |
||||
array set data [list \ |
||||
-size $size \ |
||||
-zoom $zoom \ |
||||
-pause $pause \ |
||||
-alpha 0.3 \ |
||||
-background #ff40ff \ |
||||
-exit yes \ |
||||
-command "" \ |
||||
-commandname "" \ |
||||
-ontop yes \ |
||||
-geometry "" \ |
||||
-parent "" \ |
||||
-save yes \ |
||||
-inifile [file join $HOMEDIR .config aloupe.conf] \ |
||||
-locale "" \ |
||||
-apavedir "" \ |
||||
-cs -2 \ |
||||
-fcgeom {} \ |
||||
] |
||||
} |
||||
} |
||||
|
||||
# ___________________________ Common procs ____________________________ # |
||||
|
||||
proc ::aloupe::my::Synopsis {} { |
||||
# Short info about usage. |
||||
|
||||
variable data |
||||
puts " |
||||
Syntax: |
||||
tclsh aloupe.tcl ?option value ...? |
||||
where 'option' may be [array names $data(DEFAULTS)]. |
||||
" |
||||
exit |
||||
} |
||||
#_______________________ |
||||
|
||||
proc ::aloupe::my::Message {args} { |
||||
# Displays a message, with the loupe hidden. |
||||
|
||||
variable data |
||||
wm withdraw $data(WLOUP) |
||||
tk_messageBox -parent $data(WDISP) -type ok {*}$args |
||||
wm deiconify $data(WLOUP) |
||||
} |
||||
#_______________________ |
||||
|
||||
proc ::aloupe::my::InvertBg {color} { |
||||
# Gets fg color (white/black) for a bg color. |
||||
# color - bg color |
||||
|
||||
lassign [winfo rgb . $color] r g b |
||||
if {($r%256+$b%256)<15 && ($g%256)>180} { |
||||
set res black |
||||
} elseif {$r+1.5*$g+0.5*$b > 100000} { |
||||
set res black |
||||
} else { |
||||
set res white |
||||
} |
||||
return $res |
||||
} |
||||
|
||||
# ________________________ Main and loop windows _________________________ # |
||||
|
||||
proc ::aloupe::my::CreateDisplay {start} { |
||||
# Creates the displaying window. |
||||
# start - yes, if called at start |
||||
|
||||
variable data |
||||
set sZ [expr {2*$data(-size)*$data(-zoom)}] |
||||
set data(IMAGE) [image create photo -width $sZ -height $sZ] |
||||
toplevel $data(WDISP) |
||||
wm title $data(WDISP) [::msgcat::mc Loupe] |
||||
set fg [ttk::style configure . -foreground] |
||||
set bg [ttk::style configure . -background] |
||||
set opts [ttk::style config TButton] |
||||
catch {set fg [dict get $opts -foreground]} |
||||
catch {set bg [dict get $opts -background]} |
||||
$data(WDISP) configure -background $bg |
||||
grid [label $data(WDISP).l -fg $fg -bg $bg] -row 0 -columnspan 3 -sticky we |
||||
pack [label $data(WDISP).l.lab1 -text " [::msgcat::mc Size]" -fg $fg -bg $bg] -side left -anchor e -expand 1 |
||||
pack [ttk::spinbox $data(WDISP).l.sp1 -from 8 -to 500 -justify center \ |
||||
-width 4 -textvariable ::aloupe::my::size -command ::aloupe::my::ShowLoupe \ |
||||
-validate focus -validatecommand {::aloupe::my::Valid size 8 500 25}] -side left |
||||
pack [label $data(WDISP).l.lab2 -text " [::msgcat::mc Zoom]" -fg $fg -bg $bg] -side left -anchor e -expand 1 |
||||
pack [ttk::spinbox $data(WDISP).l.sp2 -from 1 -to 50 -justify center \ |
||||
-width 2 -textvariable ::aloupe::my::zoom -validate focus \ |
||||
-validatecommand {::aloupe::my::Valid zoom 1 50 10}] -side left |
||||
pack [label $data(WDISP).l.lab3 -text " [::msgcat::mc Pause]" -fg $fg -bg $bg] -side left -anchor e -expand 1 |
||||
pack [ttk::spinbox $data(WDISP).l.sp3 -from 0 -to 60 -justify center \ |
||||
-width 2 -textvariable ::aloupe::my::pause \ |
||||
-validate focus -validatecommand {::aloupe::my::Valid pause 0 60 0}] -side left |
||||
grid [ttk::separator $data(WDISP).sep1 -orient horizontal] -row 1 -columnspan 3 -sticky we -pady 2 |
||||
grid [ttk::label $data(LABEL) -image $data(IMAGE) -relief flat] -row 2 -columnspan 3 -padx 2 |
||||
set data(BUT0) $data(WDISP).but0 |
||||
set data(BUT1) $data(WDISP).but1 |
||||
set data(BUT2) $data(WDISP).but2 |
||||
if {[set but1text $data(-commandname)] eq ""} { |
||||
set but1text [::msgcat::mc "To clipboard"] |
||||
} |
||||
grid [button $data(BUT0) -text [::msgcat::mc "Refresh"] \ |
||||
-command ::aloupe::my::Refresh -fg $fg -bg $bg -font TkFixedFont] \ |
||||
-row 3 -column 0 -sticky ew |
||||
grid [button $data(BUT1) -text $but1text \ |
||||
-command ::aloupe::my::Button2Click -font TkFixedFont] \ |
||||
-row 3 -column 1 -sticky ew |
||||
grid [button $data(BUT2) -text [::msgcat::mc Save] \ |
||||
-command ::aloupe::my::Save -fg $fg -bg $bg -font TkFixedFont] \ |
||||
-row 3 -column 2 -sticky ew |
||||
set data(-geometry) [regexp -inline \\+.* $data(-geometry)] |
||||
if {$data(-geometry) ne ""} { |
||||
wm geometry $data(WDISP) $data(-geometry) |
||||
} elseif {$data(-parent) ne ""} { |
||||
::tk::PlaceWindow $data(WDISP) widget $data(-parent) |
||||
} else { |
||||
::tk::PlaceWindow $data(WDISP) |
||||
} |
||||
if {$start} { |
||||
set defargs [list -foreground $fg -background $bg] |
||||
set data(BUTCFG) [StyleButton2 {*}$defargs] |
||||
lappend data(BUTCFG) {*}$defargs -text $but1text |
||||
} |
||||
foreach w {BUT0 BUT1 BUT2} { |
||||
set w $data($w) |
||||
foreach k {<Up> <Left>} { |
||||
bind $w $k "\ |
||||
if {{$::tcl_platform(platform)} eq {windows}} { \ |
||||
event generate $w <Shift-Tab> \ |
||||
} else { \ |
||||
event generate $w <Key> -keysym ISO_Left_Tab \ |
||||
}" |
||||
} |
||||
foreach k {<Down> <Right>} { |
||||
bind $w $k "event generate $w <Key> -keysym Tab" |
||||
} |
||||
foreach k {<Return> <KP_Enter>} { |
||||
bind $w $k "event generate $w <Key> -keysym space" |
||||
} |
||||
} |
||||
bind $data(LABEL) <ButtonPress-1> {::aloupe::my::PickColor %W %X %Y} |
||||
bind $data(WDISP) <Escape> ::aloupe::my::Exit |
||||
wm resizable $data(WDISP) 0 0 |
||||
wm protocol $data(WDISP) WM_DELETE_WINDOW ::aloupe::my::Exit |
||||
if {$data(-ontop)} {wm attributes $data(WDISP) -topmost 1} |
||||
} |
||||
#_______________________ |
||||
|
||||
proc ::aloupe::my::CreateLoupe {{geom ""}} { |
||||
# Creates the loupe window. |
||||
# geom - the predefined geometry |
||||
|
||||
variable data |
||||
frame $data(WLOUP) |
||||
wm manage $data(WLOUP) |
||||
wm withdraw $data(WLOUP) |
||||
wm overrideredirect $data(WLOUP) 1 |
||||
set canvas $data(WLOUP).c |
||||
canvas $canvas -width 100 -height 100 -background $data(-background) \ |
||||
-relief flat -bd 0 -highlightthickness 1 -highlightbackground red |
||||
pack $canvas -fill both -expand true |
||||
bind $canvas <ButtonPress-1> {::aloupe::my::DragStart %W %X %Y %x %y} |
||||
bind $canvas <B1-Motion> {::aloupe::my::Drag %W %X %Y} |
||||
bind $canvas <ButtonRelease-1> {::aloupe::my::DragEnd %W} |
||||
bind $canvas <Escape> {::aloupe::my::Exit} |
||||
after 50 " |
||||
::aloupe::my::InitGeometry $geom |
||||
wm deiconify $data(WLOUP) |
||||
wm attributes $data(WLOUP) -topmost 1 -alpha $data(-alpha) |
||||
" |
||||
} |
||||
#_______________________ |
||||
|
||||
proc ::aloupe::my::Theme {} { |
||||
# Themes the utility |
||||
|
||||
variable data |
||||
if {$data(-apavedir) eq {}} return |
||||
source [file join $data(-apavedir) apave.tcl] |
||||
::apave::initWM -cs $data(-cs) -theme alt |
||||
if {$data(-fcgeom) ne {}} { |
||||
::apave::obj chooserGeomVars {} ::aloupe::my::data(-fcgeom) |
||||
} |
||||
} |
||||
#_______________________ |
||||
|
||||
proc ::aloupe::my::Create {start} { |
||||
# Initializes and creates the utility's windows. |
||||
# start - yes, if called at start |
||||
|
||||
variable data |
||||
catch {destroy $data(WLOUP)} |
||||
catch {destroy $data(WDISP)} |
||||
catch {image delete $data(IMAGE)} |
||||
if {[set wgr [grab current]] ne ""} {grab release $wgr} |
||||
CreateDisplay $start |
||||
CreateLoupe |
||||
set data(PREVZOOM) $data(-zoom) |
||||
set data(PREVSIZE) $data(-size) |
||||
focus $data(WDISP) |
||||
} |
||||
#_______________________ |
||||
|
||||
proc ::aloupe::my::Valid {vnam val1 val2 valdef} { |
||||
# Validates spinbox's value. |
||||
# vnam - variable name |
||||
# val1 - "from" value |
||||
# val2 - "to" value |
||||
# valdef - default value |
||||
|
||||
set vnam ::aloupe::my::$vnam |
||||
set val [set $vnam] |
||||
if {$val<$val1 || $val>$val2} { |
||||
set $vnam $valdef |
||||
} |
||||
return 1 |
||||
} |
||||
|
||||
# ________________________ Drag-n-drop _________________________ # |
||||
|
||||
proc ::aloupe::my::DragStart {w X Y x y} { |
||||
# Initializes the frag-and-drop of the loupe. |
||||
# w - the loupe window's path |
||||
# X - X-coordinate of the mouse pointer |
||||
# Y - Y-coordinate of the mouse pointer |
||||
# x - X-coordinate inside the loupe |
||||
# y - Y-coordinate inside the loupe |
||||
|
||||
variable data |
||||
variable size |
||||
variable zoom |
||||
set data(FOCUS) [focus] |
||||
focus -force $data(WDISP) |
||||
set data(-size) $size |
||||
set data(-zoom) $zoom |
||||
if {$data(PREVZOOM) != $data(-zoom) || $data(PREVSIZE) != $data(-size)} { |
||||
SaveGeometry |
||||
Create no |
||||
catch {unset data(dragX)} ;# no drag-n-drop, update the loupe only |
||||
update |
||||
return |
||||
} |
||||
InitButton2 |
||||
set data(x) $x |
||||
set data(y) $y |
||||
InitGeometry |
||||
update |
||||
set data(dragX) [expr {$X - [winfo rootx $w]}] |
||||
set data(dragY) [expr {$Y - [winfo rooty $w]}] |
||||
} |
||||
#_______________________ |
||||
|
||||
proc ::aloupe::my::InitButton2 {} { |
||||
# Initializes color ("to clipboard") button. |
||||
|
||||
variable data |
||||
set data(COLOR) [set data(CAPTURE) ""] |
||||
StyleButton2 {*}$data(BUTCFG) |
||||
} |
||||
#_______________________ |
||||
|
||||
proc ::aloupe::my::ColorButton2 {} { |
||||
# Colorizes color ("to clipboard") button. |
||||
|
||||
variable data |
||||
if {$data(COLOR) ne ""} { |
||||
StyleButton2 -background $data(COLOR) -foreground $data(INVCOLOR) \ |
||||
-text $data(COLOR) |
||||
} |
||||
} |
||||
#_______________________ |
||||
|
||||
proc ::aloupe::my::Drag {w X Y} { |
||||
# Performs the frag-and-drop of the loupe. |
||||
# w - the loupe window's path |
||||
# X - X-coordinate of the mouse pointer |
||||
# Y - Y-coordinate of the mouse pointer |
||||
|
||||
variable data |
||||
if {![info exists data(dragX)]} return |
||||
set dx [expr {$X - $data(dragX)}] |
||||
set dy [expr {$Y - $data(dragY)}] |
||||
wm geometry $data(WLOUP) +$dx+$dy |
||||
} |
||||
#_______________________ |
||||
|
||||
proc ::aloupe::my::DragEnd {w} { |
||||
# Ends the frag-and-drop of the loupe and displays its magnified image. |
||||
# w - the loupe window's path |
||||
|
||||
variable pause |
||||
if {$pause} { |
||||
after 1000 [list ::aloupe::my::CountDownPause $pause $pause] |
||||
after [expr {$pause*1000}] [list ::aloupe::my::DisplayImage $w] |
||||
} else { |
||||
::aloupe::my::DisplayImage $w |
||||
} |
||||
} |
||||
#_______________________ |
||||
|
||||
proc ::aloupe::my::CountDownPause {pause p} { |
||||
# Counts down a pause. |
||||
# pause - seconds to count down |
||||
# p - remaining seconds to count down |
||||
|
||||
variable data |
||||
if {$p} { |
||||
set ::aloupe::my::pause [incr p -1] ;# shows remaining seconds |
||||
set msec [expr {$p ? 1000 : 200}] |
||||
after $msec [list ::aloupe::my::CountDownPause $pause $p] |
||||
} else { |
||||
set ::aloupe::my::pause $pause |
||||
} |
||||
} |
||||
#_______________________ |
||||
|
||||
proc ::aloupe::my::DisplayImage {w} { |
||||
# Ends the frag-and-drop of the loupe and displays its magnified image. |
||||
# w - the loupe window's path |
||||
|
||||
variable data |
||||
if {![info exists data(dragX)]} return |
||||
wm attributes $data(WLOUP) -topmost 1 -alpha 0.0 |
||||
wm attributes $data(WDISP) -alpha 0.0 |
||||
wm withdraw $data(WLOUP) |
||||
wm withdraw $data(WDISP) |
||||
set curX [winfo rootx $w] |
||||
set curY [winfo rooty $w] |
||||
set curW [winfo width $w] |
||||
set curH [winfo height $w] |
||||
catch {image delete $data(CAPTURE)} |
||||
set sz [expr {2*$data(-size)}] |
||||
set sZ [expr {$sz*$data(-zoom)}] |
||||
set data(CAPTURE) [image create photo -width $sz -height $sz] |
||||
set loupe_x [expr {$curX + $sz/2}] |
||||
set loupe_y [expr {$curY + $sz/2}] |
||||
after 40 "loupe $data(CAPTURE) $loupe_x $loupe_y $sz $sz 1" |
||||
after 50 |
||||
update ;# enough time to hide the window and capture the image |
||||
after 50 |
||||
catch { |
||||
$data(IMAGE) copy $data(CAPTURE) -from 0 0 $sz $sz \ |
||||
-to 0 0 $sZ $sZ -zoom $data(-zoom) |
||||
} |
||||
wm deiconify $data(WDISP) |
||||
wm deiconify $data(WLOUP) |
||||
after idle " \ |
||||
wm attributes $data(WLOUP) -topmost 1 -alpha $data(-alpha);\ |
||||
wm attributes $data(WDISP) -alpha 1.0" |
||||
focus -force $data(BUT0) |
||||
} |
||||
#_______________________ |
||||
|
||||
proc ::aloupe::my::Refresh {} { |
||||
# Refreshes the loupe image without mouse click. |
||||
|
||||
variable data |
||||
InitButton2 |
||||
DragEnd $data(WLOUP) |
||||
} |
||||
|
||||
# ________________________ Geometry _________________________ # |
||||
|
||||
proc ::aloupe::my::ShowLoupe {} { |
||||
# Re-displays the loupe at changing its size. |
||||
|
||||
variable data |
||||
variable size |
||||
set data(-size) $size |
||||
lassign [split [wm geometry $data(WLOUP)] +] -> x y |
||||
set sz [expr {2*$size}] |
||||
destroy $data(WLOUP) |
||||
CreateLoupe ${sz}x${sz}+$x+$y |
||||
ColorButton2 |
||||
} |
||||
#_______________________ |
||||
|
||||
proc ::aloupe::my::InitGeometry {{geom ""}} { |
||||
# Gets and sets the geometry of the loupe window, |
||||
# based on the image label's sizes and the zoom factor. |
||||
# geom - the predefined geometry |
||||
|
||||
variable data |
||||
if {$geom eq ""} { |
||||
set sz [expr {2*$data(-size)}] |
||||
lassign [winfo pointerxy .] x y |
||||
if {[info exists data(x)]} {set dx $data(x)} {set dx $sz/2} |
||||
if {[info exists data(y)]} {set dy $data(y)} {set dy $sz/2} |
||||
set x [expr $x-$dx] |
||||
set y [expr $y-$dy] |
||||
set geom ${sz}x${sz}+$x+$y |
||||
} |
||||
wm geometry $data(WLOUP) $geom |
||||
} |
||||
#_______________________ |
||||
|
||||
proc ::aloupe::my::SaveGeometry {} { |
||||
# Saves the displaying window's geometry. |
||||
|
||||
variable data |
||||
set data(-geometry) "" |
||||
catch {set data(-geometry) [wm geometry $data(WDISP)]} |
||||
} |
||||
|
||||
# ________________________ Widgets' styles _________________________ # |
||||
|
||||
proc ::aloupe::my::StyleButton2 {args} { |
||||
# Makes a style for Tbutton. |
||||
# args - options ("name value" pairs) |
||||
# Returns the TButton's configuration options. |
||||
|
||||
variable data |
||||
if {[dict exists $args -text]} { |
||||
$data(BUT1) configure -text [dict get $args -text] |
||||
set args [dict remove $args -text] |
||||
} |
||||
set fg [dict get $args -foreground] |
||||
set bg [dict get $args -background] |
||||
$data(BUT1) configure -foreground $fg -background $bg |
||||
return {} |
||||
} |
||||
|
||||
# ________________________ Capturing image _________________________ # |
||||
|
||||
proc ::aloupe::my::Button2Click {} { |
||||
# Processes the click on 'Clipboard' button. |
||||
|
||||
variable data |
||||
if {$data(COLOR) ne ""} { |
||||
StyleButton2 -background $data(INVCOLOR) -foreground $data(COLOR) |
||||
update idletasks |
||||
after 60 ;# just to make the click visible |
||||
} |
||||
if {[HandleColor] && !$data(-exit) && $data(-command) ne ""} { |
||||
SaveGeometry |
||||
{*}[string map [list %c $data(COLOR)] $data(-command)] |
||||
} |
||||
} |
||||
#_______________________ |
||||
|
||||
proc ::aloupe::my::IsCapture {} { |
||||
# Checks if the image was captured. |
||||
|
||||
variable data |
||||
if {$data(CAPTURE) eq ""} { |
||||
Message -title [msgcat::mc {Color of Image}] -icon warning \ |
||||
-message [msgcat::mc "Click, then drag and drop\nthe loupe to get the image."] |
||||
return no |
||||
} |
||||
return yes |
||||
} |
||||
#_______________________ |
||||
|
||||
proc ::aloupe::my::HandleColor {{doclb yes}} { |
||||
# Processes the image color under the mouse pointer, |
||||
# optionally saving it to the clipboard. |
||||
# doclb - if 'yes', means "put the color into the clipboard" |
||||
# Returns 'yes' if the color was chosen. |
||||
|
||||
variable data |
||||
set res no |
||||
if {[IsCapture]} { |
||||
if {$data(COLOR) eq ""} { |
||||
Message -title [msgcat::mc {Color of Image}] -icon warning \ |
||||
-message [msgcat::mc "Click the magnified image\nto get a pixel's color.\n\nThen hit this button."] |
||||
} else { |
||||
if {$doclb && $data(-commandname) eq ""} { |
||||
clipboard clear |
||||
clipboard append -type STRING $data(COLOR) |
||||
} |
||||
ColorButton2 |
||||
set res yes |
||||
} |
||||
} |
||||
return $res |
||||
} |
||||
#_______________________ |
||||
|
||||
proc ::aloupe::my::PickColor {w X Y} { |
||||
# Gets the image color under the mouse pointer. |
||||
# w - the image label's path |
||||
# X - X-coordinate of the mouse pointer |
||||
# Y - Y-coordinate of the mouse pointer |
||||
|
||||
variable data |
||||
if {![IsCapture]} return |
||||
set x [expr {max(($X - [winfo rootx $w] -4),0)}] |
||||
set y [expr {max(($Y - [winfo rooty $w] -4),0)}] |
||||
catch { |
||||
lassign [$data(IMAGE) get $x $y] r g b |
||||
set data(COLOR) [format "#%02x%02x%02x" $r $g $b] |
||||
set data(INVCOLOR) [InvertBg $data(COLOR)] |
||||
HandleColor no |
||||
set msec [clock milliseconds] |
||||
if {[info exists data(MSEC)] && [expr {($msec-$data(MSEC))<400}]} { |
||||
Button2Click |
||||
} |
||||
set data(MSEC) $msec |
||||
} |
||||
} |
||||
#_______________________ |
||||
|
||||
proc ::aloupe::my::SaveOptions {} { |
||||
# Saves options of appearance to a file. |
||||
|
||||
variable data |
||||
variable size |
||||
variable zoom |
||||
variable pause |
||||
if {!$data(-save)} return |
||||
set data(-size) $size |
||||
set data(-zoom) $zoom |
||||
set data(-pause) $pause |
||||
set w $data(WDISP) |
||||
catch {file mkdir [file dirname $data(-inifile)]} |
||||
catch { |
||||
append opts {[options]} \n |
||||
foreach opt [array names data] { |
||||
if {$opt in {-size -geometry -background -zoom -pause -alpha -ontop}} { |
||||
if {$opt eq "-geometry"} { |
||||
set val [wm geometry $w] |
||||
} else { |
||||
set val $data($opt) |
||||
} |
||||
append opts "[string range $opt 1 end]=$val" \n |
||||
} |
||||
} |
||||
set chan [open $data(-inifile) w] |
||||
puts -nonewline $chan $opts |
||||
close $chan |
||||
} |
||||
} |
||||
|
||||
# ________________________ Save / restore options _________________________ # |
||||
|
||||
proc ::aloupe::my::RestoreOptions {} { |
||||
# Restores options of appearance from a file. |
||||
|
||||
variable data |
||||
if {!$data(-save)} return |
||||
if {![file exists $data(-inifile)]} return |
||||
set chan [open $data(-inifile)] |
||||
set data(CONFIG) [read $chan] |
||||
close $chan |
||||
set svd $data(DEFAULTS) |
||||
foreach line [split $data(CONFIG) \n] { |
||||
if {[string match "*=*" $line]} { |
||||
set opt -[string range $line 0 [string first = $line]-1] |
||||
set val [string range $line [string length $opt] end] |
||||
set ${svd}($opt) [set data($opt) $val] |
||||
} |
||||
} |
||||
} |
||||
#_______________________ |
||||
|
||||
proc ::aloupe::my::Save {} { |
||||
# Saves the magnified image to a file. |
||||
|
||||
variable data |
||||
if {![IsCapture]} return |
||||
wm withdraw $data(WLOUP) |
||||
set filetypes { {"PNG Images" .png} {"All Image Files" {.png .gif}} } |
||||
set file [file tail $::aloupe::filename] |
||||
set argl [list -parent $data(WDISP) -title [::msgcat::mc "Save the Loupe"] \ |
||||
-filetypes $filetypes -defaultextension .png -initialfile $file] |
||||
if {$data(-fcgeom) ne {}} { |
||||
set file [::apave::obj chooser tk_getSaveFile ::aloupe::filename {*}$argl] |
||||
} else { |
||||
catch {::apave::obj themeExternal "$data(WLOUP)*"} ;# theme the file chooser |
||||
set file [tk_getSaveFile {*}$argl] |
||||
} |
||||
if {$file ne ""} { |
||||
set ::aloupe::filename $file |
||||
if {![regexp -nocase {\.(png|gif)$} $file -> ext]} { |
||||
set ext "png" |
||||
append file ".${ext}" |
||||
} |
||||
if {[catch {$data(IMAGE) write $file -format [string tolower $ext]} err]} { |
||||
Message -title "Error Writing File" -icon error \ |
||||
-message "Error writing to file \"$file\":\n$err" |
||||
} |
||||
} |
||||
ShowLoupe |
||||
} |
||||
#_______________________ |
||||
|
||||
proc ::aloupe::my::Exit {} { |
||||
# Clears all and exits. |
||||
|
||||
variable data |
||||
SaveOptions |
||||
if {$data(-exit)} exit |
||||
SaveGeometry |
||||
catch {image delete $data(IMAGE)} |
||||
catch {image delete $data(CAPTURE)} |
||||
catch {destroy $data(WDISP)} |
||||
catch { |
||||
wm withdraw $data(WLOUP) |
||||
destroy $data(WLOUP) |
||||
} |
||||
} |
||||
# __________________________ Interface procs ____________________________ # |
||||
|
||||
proc ::aloupe::option {opt} { |
||||
# Returns a value of aloupe option. |
||||
# opt - the option's name |
||||
|
||||
variable data |
||||
return $data($opt) |
||||
} |
||||
#_______________________ |
||||
|
||||
proc ::aloupe::run {args} { |
||||
# Runs the loupe. |
||||
# args - options of the loupe |
||||
|
||||
if {$::aloupe::starterr} { |
||||
RunSolo |
||||
return |
||||
} |
||||
variable my::data |
||||
variable my::size |
||||
variable my::zoom |
||||
# save the default settings of aloupe |
||||
set data(-commandname) "" |
||||
if {![info exists my::data(DEFAULTS)]} { |
||||
set defar ::aloupe::_DEFAULTS_ |
||||
array set $defar [array get my::data] |
||||
set my::data(DEFAULTS) $defar |
||||
} |
||||
catch {set my::data(-inifile) [dict get $args -inifile]} |
||||
catch { |
||||
if {([dict exists $args -save] && [dict get $args -save]) || \ |
||||
(![dict exists $args -save] && $my::data(-save))} { |
||||
my::RestoreOptions |
||||
} |
||||
} |
||||
# restore the default settings of aloupe (for a 2nd/3rd... run) |
||||
set svd $my::data(DEFAULTS) |
||||
foreach an [array names $svd] { |
||||
set my::data($an) [set ${svd}($an)] ;# "by variable address" |
||||
} |
||||
foreach {a v} $args { |
||||
if {($v ne "" || $a in {-geometry -fcgeom}) && \ |
||||
[info exists my::data($a)] && [string is lower [string index $a 1]]} { |
||||
set my::data($a) $v |
||||
} else { |
||||
puts "Bad option: $a \"$v\"" |
||||
my::Synopsis |
||||
} |
||||
} |
||||
if {$my::data(-locale) ne {}} { |
||||
catch { |
||||
::msgcat::mcload [file join [file dirname [info script]] msgs] |
||||
::msgcat::mclocale $my::data(-locale) |
||||
} |
||||
} |
||||
catch {::apave::obj untouchWidgets "*_a_loupe_loup*"} ;# don't theme the loupe |
||||
set my::size [set my::data(PREVSIZE) $my::data(-size)] |
||||
set my::zoom [set my::data(PREVZOOM) $my::data(-zoom)] |
||||
set my::pause $my::data(-pause) |
||||
set my::data(WDISP) "$data(-parent)._a_loupe_disp" |
||||
set my::data(WLOUP) "$data(-parent)._a_loupe_loup" |
||||
set my::data(LABEL) "$data(WDISP).label" |
||||
set my::data(COLOR) [set data(CAPTURE) ""] |
||||
my::Theme |
||||
my::Create yes |
||||
} |
||||
|
||||
# ___________________________ Stand-alone run ___________________________ # |
||||
|
||||
if {$::aloupe::solo} { |
||||
wm withdraw . |
||||
catch { |
||||
ttk::style config TButton -width 9 -buttonborder 1 -labelborder 0 -padding 1 |
||||
} |
||||
::aloupe::run {*}$::argv |
||||
} |
||||
# _________________________________ EOF _________________________________ # |
||||
#-ARGS1: -locale ua -alpha .2 -background "yellow" -ontop 1 -save 1 -commandname "Get" |
||||
#-RUNF1: ~/PG/github/pave/tests/test2_pave.tcl 23 9 12 "small icons" |
||||
@ -0,0 +1,22 @@
|
||||
chan configure stdout -buffering none |
||||
chan configure stderr -buffering none |
||||
puts -nonewline stderr "1 hello on stderr with crlf newline\r\n" |
||||
flush stderr |
||||
puts -nonewline stdout "2 hello on stdout with crlf newline\r\n" |
||||
flush stdout |
||||
puts -nonewline stderr "3 hello on stderr with unix newline\n" |
||||
flush stderr |
||||
puts -nonewline stdout "4 hello on stdout with unix newline\n" |
||||
flush stdout |
||||
puts -nonewline stderr "5 hello on stderr no line-ending" |
||||
flush stderr |
||||
puts -nonewline stdout "6 hello on stdout no line-ending" |
||||
flush stdout |
||||
puts -nonewline stderr "7 hello on stderr no line-ending" |
||||
flush stderr |
||||
set ::tcl_interactive 1 |
||||
|
||||
exit {*}$::argv |
||||
|
||||
|
||||
|
||||
@ -0,0 +1,5 @@
|
||||
package require punk |
||||
package require punk::config |
||||
punk::config::init |
||||
package require punk::args::moduledoc::tclcore |
||||
punk::help {*}$::argv |
||||
@ -0,0 +1,6 @@
|
||||
package require punk |
||||
package require punk::config |
||||
punk::config::init |
||||
package require punk::args::moduledoc::tclcore |
||||
punk::help {*}$::argv |
||||
exit 0 |
||||
@ -0,0 +1,7 @@
|
||||
package require punk::ns |
||||
package require punk::nav::ns |
||||
package require punk::netbox |
||||
package require punk::netbox::man |
||||
punk::netbox::init |
||||
puts [punk::netbox::man::about Description Version] |
||||
puts -nonewline stdout [punk::ns::pkguse ::punk::netbox::man] |
||||
@ -0,0 +1,12 @@
|
||||
package require patternpunk |
||||
package require punk::ansi |
||||
package require textblock |
||||
apply { {} { |
||||
set l "[punk::ansi::a+ term-blue][>punk . logo2][punk::ansi::a]" |
||||
set f [textblock::frame -type arc -ansiborder [punk::ansi::a+ green] $l] |
||||
set info "\n[info patchlevel]\n[>punk . version]" |
||||
puts -nonewline stdout \n[textblock::join -- $f " " $info] |
||||
} } |
||||
#puts -nonewline stdout [n/new ::[set ::tcl_platform(user)]] |
||||
puts -nonewline stdout [punk::nav::ns::newns ::[set ::tcl_platform(user)]] |
||||
#mode raw |
||||
@ -1,8 +1,13 @@
|
||||
#puts -nonewline stdout "info script\r\n" |
||||
#puts stdout "[info script]" |
||||
puts stdout "argc: $::argc" |
||||
puts stdout "argv one arg per line, each line followed by dotted line." |
||||
foreach a $::argv { |
||||
puts stdout $a |
||||
puts stdout [string repeat - 40] |
||||
} |
||||
#puts -nonewline stdout "info script\r\n" |
||||
#puts stdout "[info script]" |
||||
puts stdout "argc: $::argc" |
||||
puts stdout "argv one arg per line, each line followed by dotted line." |
||||
foreach a $::argv { |
||||
puts stdout $a |
||||
puts stdout [string repeat - 40] |
||||
} |
||||
|
||||
#it can be useful to have a shutdown delay when testing with a launch mechanism that doesn't capture the output of the launched process - so that we can see the output before the process exits. |
||||
#(e.g running from windows explorer to test the arguments in the registry for file associations and shell open commands) |
||||
#after 10000 |
||||
|
||||
|
||||
@ -0,0 +1,5 @@
|
||||
if {[catch {package require tk}]} { |
||||
package require Tk |
||||
} |
||||
label .label -text "Hello World" |
||||
pack .label |
||||
Loading…
Reference in new issue