#!/bin/sh
#\
exec wish "$0" ${1+"$@"}

set home $env(HOME)

set optfile $home/barclock.opt

set menubar 0

switch $tcl_platform(platform) {
	unix {
		if {"$tcl_platform(os)" == "Darwin"} {
			set menubar 1
			set optfile $home/Library/Preferences/Barclock
		} else {
			set optfile $home/.barclock.rc
		}
	}
	windows {
	}
	macintosh {
		set menubar 1
	}
}

# IMAGES_START
set data(center_guard) {
R0lGODlhCgCBAIAAAP///wAAACwAAAAACgCBAAACeISPqRBhjSBzR8pH78Qx
U75VXgeCmvWF5yiWaoqSoQmztLy6cTu/eK2z+Xi53u5GBBqFxyHy6Yw2p8xq
8LrEFrdK7u+bBEOp2q5ZLLVm196we6xuw8toMvv8TtPzdrn+XheHNwfIJxi4
R+jXN7jg+AgZKTlJWQlZAAA7}
set data(dgt0) {
R0lGODlhDgCBAKIAAP///8zMzJmZmWZmZjMzMwAAAAAAAAAAACwAAAAADgCB
AAAD2wi63P6uyKJknJW2qe3GgMdw2eWJCxlqI4hmJ5u6MtzVa2zee/npP17Q
1wIWhUfizLhENpU2aM4ZXfWsQ2xS++RWX1OpCjzGla9kGtqszqaZXzY87KW/
qXY5/uzWi9tbd39zfIF+dYVdgoiAioeLkI+Sa5R9lYaXjplxm3mdiZyWopij
mqWhpKmmqqirrq2wnqeyrLSvtrGguLsQDAIEEgQBD8AcBQINASgvAgUDLQ3A
wwvSDNULA8ct0wrZzzPcAN7bDOPg5drUBeHX3elQyjJvxWAAv8Hhvfq9CQA7}
set data(dgt1) {
R0lGODlhDgCBAKIAAP///8zMzGZmZjMzMwAAAAAAAAAAAAAAACwAAAAADgCB
AAADxgi63P6MSBLpmlbJum8GWMV9nTaJXgmSpzeipiq35uumrF3j8DrrK+Ds
x7vFcsXdsRcy+pBLZ1P5ZNKCSWyUOtVWpdch9MsNs4hbb1dsRZPVZuF5vJ63
6fEsG+yuy/96dnx4fXlpe2WFioSMd46Dj4mNkJSSkXCLl4iYk5aVnJqCnqOg
n5unoqWkqICHqayBrW+wrrIQtxICtwACuRABGLoPE73CDcABvATGDAEDCsW7
yswP0bvWt9gQ2tXL0twO4A3i0uUKCQA7}
set data(dgt2) {
R0lGODlhDgCBAKIAAP///8zMzJmZmWZmZjMzMwAAAAAAAAAAACwAAAAADgCB
AAAD0gi63P6slCjnkhRfqyoHWldR2ReC41aS2+mm4qq2Zv3KMc2Ktz7zNRxK
+OoBdyhjMujLHX9LpEcKGzatT2cUOuVWi8wsdqvtlr+2MHlsZqOJaaqyDZar
6XHv/H2t6+98Yn5ne4WAhnaJf4qEh46MboiLk42Qg5GPlJiWeZWal6Cdm5+i
oXCnfaWqqIKrqaxrpq+zrUIQDgIEBQQDEB4SAg4BuwoBuh8AAQEMw8gPJ77O
DMfBEAISvQ/NBMvaVQ7Qz9IM19m3AxIE6usN6L/ht/EOCQA7}
set data(dgt3) {
R0lGODlhDgCBAKIAAP///8zMzJmZmWZmZjMzMwAAAAAAAAAAACwAAAAADgCB
AAAD0wi63P6qyCljsbQCnafF2bd11whSIllyZNqaY+fKsDqH9cvSO96jOd5K
NxSePEFfUXlkNYfPG/CHpDpjTOx0uY0mu9oqV+y1QsNX25eMPqvNUvZ7nCaW
6W57O1437td9WXN3hH9wgHl+g4Z4fImCeouSkZSKlZCWmZibYJOanZegn3Kh
pKOBopymqqirqa+usa2zj7C0IhAOASoBDLskvbkCGhDDBQPCxA/GyLkUBMEO
BARAuQDUzbm7BNYAv93D3AsBA8EBxg2/09XjAxIE2d3yDwkAOw==}
set data(dgt4) {
R0lGODlhDgCBAKIAAP///8zMzJmZmWZmZjMzMwAAAAAAAAAAACwAAAAADgCB
AAAD0gi63P6qFCdlnK1im+ulHsAx2tdx41KKGBmmF9qq7xxvNiuD+4nzP5/J
1SMGjUNaUXlkJm9PXRPKAkZXMOm1Zq0KvUiwU0zNYnPnrpn7XS/LaHbYPdWS
7fTtGx/fp9t9dX9zgXqCcmN5d4OJhYuIcGqOipSTlpKYgJmEm42dkZqhnKKe
pKCjqKWpp6qtrK98n7Gms6u1rrewjLohEL4AAwUCvwFZHQG/dw0CBQTJBMK/
0MO/HMEDD9YF2A3XCt4N0BoVyAvi4wXlD+C+7BDuyfENCQA7}
set data(dgt5) {
R0lGODlhDgCBAKIAAP///8zMzJmZmWZmZjMzMwAAAAAAAAAAACwAAAAADgCB
AAADywi63P6qyOJknJWCqZndWPNx2fV5GimmIWp2y9jG7Em/JWhf+Nq7Ohgv
mFMBjTeiT3mcDZFPJ+iXhE6ZValsd7VuhV1tDfwtiqlRbnnpHZvVbvYZmybH
m3B0OE/f2/VreH99gVl8bYB3hoOIhIp1b4xzjZSTloeXkpibmp2Rn3KcoIKj
i6WQoZ6pp36shaikq7KxtKaztrWwuLtDEA8DHFIEwVzDvknHXBkSAwIQEgTD
Es6+AdLHvb7KS8lgCwET1AzRHOIoBAPY6uoJADs=}
set data(dgt6) {
R0lGODlhDgCBAKIAAP///8zMzJmZmWZmZjMzMwAAAAAAAAAAACwAAAAADgCB
AAAD1Ai63P6qlCirpNResHXFnDeFmQaKYyeeKxl6LOyisTm3qpzbu1X7N10K
NxSWgL1PkFdkHpVJ1VP6claRTex0uP1Bs9/uUnsNl6m0sTkd5Z7dbDCaKG57
58b3HU7Xq/FWcXVyfHmCfnZ/hYF9h46NkIaRjJKVlJdkj5aZk5yba52gn4Ce
mKKmpKelq6qtqa+LrLB7tIq1ELgKBAUEuS4QAhIBucK5uwPGvL4eBMMMwcwN
u70LG9UFAgy72dfOCgMFyAvb2tgMAcUA0A4i1A0B0+K+8xAJADs=}
set data(dgt7) {
R0lGODlhDgCBAKIAAP///8zMzJmZmWZmZjMzMwAAAAAAAAAAACwAAAAADgCB
AAADwAi63P6qyBkpmBZXfTMuG9hx5BeG0jl66dqWsPjJbI3Sr7ne6tzrsZzQ
5sIZh7xd8RdLBo3OGnKp9FWBUij1ySRaudfmNtudfslhL3ZoXh+1ZzbcHZWX
5+L4+85Pt/N0Y3Z+eGqAh4aJf4qFi46NkH1gk2iUg5Z7hJKVnJedmZh1oJ+i
pYKjnqmoq6Z6rYEQDgQzEgMMs7S2sR0Bux27AxK9sRICu7MEuwItxCK7zBAB
BcnKBbqxwdcQ2b7cvt++CQA7}
set data(dgt8) {
R0lGODlhDgCBAKIAAP///8zMzJmZmWZmZjMzMwAAAAAAAAAAACwAAAAADgCB
AAAD1Ai63P6qyBKnrBfYbPH0HvdpG0h2J5WK7Ihu6lumYezOcm7rtQn7uBtv
tSu2ejQicPhLNnVHpTPYij6FWCS0qMVaqUaudLvMjr3iazUN7q7LX2b7/J7K
72Z1GM7Gx/Nzem57doB+fYaJf4uIjHyPhY6RjZSQZJOWaJl1l52amKCenJ+i
hKWDqHSmpKyjroQQsQMEBQQBELQWAg4SuwABGQzBJLwFtxUOA7W3AsPCIw/A
E7bFAwrSxwvDtNYLyt3Xw83gv8694QW+2jAqDQG5BOqx8/MJADs=}
set data(dgt9) {
R0lGODlhDgCBAKIAAP///8zMzJmZmWZmZjMzMwAAAAAAAAAAACwAAAAADgCB
AAAD3Ai63P6uFCVlnKBiZnO91Nd0Guh1HFaOqpiG6EK6chuH8Fbn5vqeOhyw
RxP6dkMWT5n8HY1Fz9IZnd2kTeQTu7UGuVXb10u8kpldcXmsRoen2ncWam5T
63A6Ow/Gz/t7f2d3gWl8g3F+hoJ2iYVyi5GQk4qUj5WYl5prnG6ZnYSgjqJ6
pICmiKWem6uojaqhrbKxtKOztrWwuLsQDwMEBQQBEMAaAhfHAAF+CsADDAIF
zwvLOgPSDNVMzcEsA8PRBckM1xpfCr8D5b0AwATsHsMQ1dMQEu/zxfD7+wkA
Ow==}
set data(dgta) {
R0lGODlhDgCBAKIAAP///8zMzJmZmWZmZjMzMwAAAAAAAAAAACwAAAAADgCB
AAADXAi63P4wykmrvTjrzbv/YCiOZGmeaKqubOu+cCzPdG3feK7vfO//QExg
IJgMCoUJgVAoQgJNwiAiKASWkQEBUA1AClOoswFFIqeO6oDIfGAVXQd4IXYM
vAvB+JQAADs=}
set data(dgtbl) {
R0lGODlhDgCBAKIAAP///8zMzJmZmWZmZjMzMwAAAAAAAAAAACwAAAAADgCB
AAAD2wi63P6uyKJknJW2qe3GgMdw2eWJCxlqI4hmJ5u6MtzVa2zee/npP17Q
1wIWhUfizLhENpU2aM4ZXfWsQ2xS++RWX1OpCjzGla9kGtqszqaZXzY87KW/
qXY5/uzWi9tbd39zfIF+dYVdgoiAioeLkI+Sa5R9lYaXjplxm3mdiZyWopij
mqWhpKmmqqirrq2wnqeyrLSvtrGguLsQDAIEEgQBD8AcBQINASgvAgUDLQ3A
wwvSDNULA8ct0wrZzzPcAN7bDOPg5drUBeHX3elQyjJvxWAAv8Hhvfq9CQA7}
set data(dgtm) {
R0lGODlhDgCBAKIAAP///8zMzJmZmWZmZjMzMwAAAAAAAAAAACwAAAAADgCB
AAADYwi63P4wykmrvTjrzbv/YCiOZGmeaKqubOu+cCzPdG3feK7vfO//QE5g
IFAMiw1BoVAkLB2D5QBQcDqUA4LS2ohuCdFrISANd8fOYUEcEBAAZkYcvk6O
F3NFNICvM9oMAkgiCQA7}
set data(dgtp) {
R0lGODlhDgCBAKIAAP///8zMzJmZmWZmZgAAAAAAAAAAAAAAACwAAAAADgCB
AAADVAi63P4wykmrvTjrzbv/YCiOZGmeaKqubOu+cCzPdG3feK7vfO//QEtg
ICAGIAOCUjl4CAhHQDLKmCoChGbjGcUKHElikuBcZqlV6IQ7SVLYkiEsAQA7}
set data(left_guard) {
R0lGODlhGQCBAIAAAP///wAAACwAAAAAGQCBAAAC/4SPqcutEQxkcAJ7Y6ZV
6g0+XWhhSaVh5XeOasoiqHesnE2HLQ6asvvh7WA14mJGMop4wh9TOcz1YsWn
NJq8OpXNKhe6lXY9Vl04a/aKwWq0r/3SwoNs8lduX+Mz5XfeTfUXlyZIt4c0
6Md3R7io14hoCAlUdEiZoxhZOdkX6Ah4w5h5ORX6ONppCnpEOvaZ6KmJGdta
9yqJKkqbysq7pKsKG4y7C9xr/HtarDy8mct8DJ28Oi0cTY1lXU3cPNtdeq2d
zR1Ovu28jH0mvm4+jv7tKgt+7l0Of29fT/+u38/fDt8+ebUs+fpH8GBAfwsB
zhGI0Na8hMgiGqzYkKI0iy2cMD5k+NFhIYgZJRbsuLHkxZQhNapraVIhzJWN
HNi8iTOnzp08e/r8CTSozQIAOw==}
set data(right_guard) {
R0lGODlhGQCBAIAAAP///wAAACwAAAAAGQCBAAAC/4SPqcu9ERCEigJ745la
aoxloWGBnXiSXxdy1bqdblKy8vSqsTdm+q/q1XYxIQyIyvmQMw+whaMdl8HU
0sSzDplRJxVqfN7C37F2Cj6Ls0psUV1mS9fvtk3udVftxP08XvenlyR4F5hn
6IfYR7jIRTbYRBTZNZnYaMko+UMJebl59VnJKeqpORp6avoI19la+qoay8pH
WyhbS4VJintr66gLuhWMOpyWe+xLvLo824xsBo2X+Uv9rJwMnG29zVvtfa0d
jT0uPg3enfqtHs5d7n7Onm78jl4vf08fr38I32+/D00+gQHpKPJ3EOA/fAUB
JWS4kN9DibsgTiQYEeNFgzgVKQrT2BHkR44jHYYkWUxkSpTM5qlsOZClM5cy
pWWsSa6hK5sbdTn4CTSo0KFEixo9ijSpUqEFAAA7}

wm withdraw .
wm title . barclock
wm resizable . 0 0
wm sizefrom . program
wm overrideredirect . 1
wm deiconify .
array set img {
:	center_guard
0	dgt0
1	dgt1
2	dgt2
3	dgt3
4	dgt4
5	dgt5
6	dgt6
7	dgt7
8	dgt8
9	dgt9
a	dgta
" "	dgtbl
m	dgtm
p	dgtp
<	left_guard
>	right_guard
}

foreach ch [array names img] {
	set name $img($ch)
	if {[info exists data($name)]} {
		image create photo lg_$name -data $data($name)
	} elseif {[info exists work]} {
		image create photo lg_$name -file $work/$name.gif
	} else {
		wm withdraw .
		tk_dialog .oops "barclock" \
			"No data for character '$ch'" error 0 "Quit"
		exit
	}
	set w [image width lg_$name]
	set h [image height lg_$name]
	image create photo sm_$name -width [expr $w / 2] -height [expr $h / 2 ]
	sm_$name copy lg_$name -subsample 2 2
	set hclip [expr $h / 3]
	image create photo cl_$name -width $w -height $hclip
	cl_$name copy lg_$name -from 0 [expr $h - $hclip] $w $h
	image create photo ti_$name -width [expr $w / 2] -height [expr $hclip / 2 ]
	ti_$name copy cl_$name -subsample 2 2
}

set size_prefix {sm_ lg_ cl_ ti_}
set size_border {4 8 8 4}
set size_index 1

proc setsize {{save 1}} {
	global size_index size_prefix size_border border last_time size
	set size [lindex $size_prefix $size_index]
	set last_time "            "
	if $save {
		write_options
	}
}

set last_border -1
proc check_border {} {
	global last_border size_border size_index
	set new_border [lindex $size_border $size_index]
	if {$new_border != $last_border} {
		.t configure -border $new_border
	}
}

proc read_options {} {
	global optfile
	if [file exists $optfile] {
		catch {uplevel #0 source $optfile}
	}
}

proc write_options {} {
	global optfile size_index saved_geometry
	if [catch {set fp [open $optfile.tmp w]} e] {
		puts stderr $e
		return
	}
	foreach v {size_index saved_geometry} {
		if ![info exists $v] continue
		if [catch {puts $fp [list set $v [set $v]]} e] {
			puts stderr $e
			close $fp
			file delete $optfile.tmp
			return
		}
	}
	if [catch {close $fp} e] {
		puts stderr $e
		file delete $optfile.tmp
		return
	}
	catch {file rename -force $optfile $optfile.bak}
	catch {file rename -force $optfile.tmp $optfile}
}

proc check_geometry {} {
	global wm_geometry saved_geometry
	if ![info exists wm_geometry] {
		if ![info exists saved_geometry] {
			return
		}
		set_geometry $saved_geometry
		return
	}
	if {[get_geometry]} {
		if ![info exists saved_geometry] {
			save_geometry $wm_geometry
		}
		if {"$wm_geometry" != "$saved_geometry"} {
			save_geometry $wm_geometry
		}
	}
}

proc get_geometry {} {
	global wm_geometry
	set wm_geometry [wm geometry .]
	regsub {^[^+-]*} $wm_geometry "" wm_geometry
	if ![string length $wm_geometry] {
		unset wm_geometry
		return 0
	}
	return 1
}

proc set_geometry {g} {
	global wm_geometry

	wm geometry . $g
	set wm_geometry $g
}

proc save_geometry {g} {
	global wm_geometry saved_geometry

	set saved_geometry $wm_geometry
	write_options
}

proc nextsize {} {
	global size_index size_prefix
	incr size_index
	if {$size_index >= [llength $size_prefix]} {
		set size_index 0
	}
}

read_options
setsize 0

set menus {.popup}
menu .popup -tearoff 0

if {$menubar} {
	lappend menus .mb.options
	menu .mb -tearoff 0
	menu .mb.options -tearoff 0
	.mb add cascade -menu .mb.options -label Options
}

foreach {l v} {Small 0 Large 1 Flat 2 "Small Flat" 3} {
	foreach m $menus {
	    $m add radiobutton \
		-label $l -variable size_index -value $v -command {
		    setsize
		    after 0 tick
		}
	}
}
.popup add separator
.popup add command -label Quit -command {after 0 destroy .}

if {$menubar} {
	. configure -menu .mb
}

pack [frame .t -relief flat -border 8 -bg white] -side top

foreach pos {10 0 1 2 3 4 5 6 7 8 9 11} {
	pack [label .t.l$pos -image $size$img( ) -border 0] -side left
}


proc tick {} {
	global last_time img size first_time
	check_border

	set time [
	  string tolower [clock format [clock seconds] -format {<%I:%M:%S>%p}]
	]
	set i 0
	foreach new [split $time ""] old [split $last_time ""] {
		if {"$new" != "$old"} {
			.t.l$i configure -image $size$img($new)
		}
		incr i
	}
	check_geometry
	set last_time $time
	set first_time 0
	after 1000 tick
}

set following 0
proc follow {on {x 0} {y 0}} {
  global following startx starty orig_motion winx winy

  if $on {
    if $following return
    set startx $x
    set starty $y
    set geom [wm geometry .]
    if [regexp {[0-9]*x[0-9]*([+-][0-9]*)([+-][0-9]*)$} $geom _ winx winy] {
      regsub {^[+]*} $winx {} winx
      regsub {^[+]*} $winy {} winy
    }
    if [info exists orig_motion] {
      set orig_motion [bind . <Button1-Motion>]
    }
    bind . <Button1-Motion> {+following %X %Y}
    set following 1
  } else {
    if !$following return
    if [info exists orig_motion] {
      bind . <Button1-Motion> $orig_motion
    }
    set following 0
  }
}

proc following {x y} {
  global following startx starty winx winy

  if !$following return

  incr x [expr $winx - $startx]
  incr y [expr $winy - $starty]

  if {$x < 0} {set x 0}
  if {$y < 0} {set y 0}

  wm geometry . +$x+$y
}

bind . <Control-ButtonPress-1> {+.popup post %X %Y}
bind . <ButtonPress-3> {+.popup post %X %Y}
bind . <ButtonPress-2> {+.popup post %X %Y}
bind . <ButtonPress-1> {+.popup unpost; follow 1 %X %Y}
bind . <ButtonRelease-1> {+follow 0}
bind . <Any-Key-q> {+after 0 destroy .}
bind . <Any-Key-w> {+after 0 destroy .}
bind . <Any-Key-Escape> {+after 0 destroy .}
bind . <Any-Key-space> {+nextsize; setsize; after 0 tick}

tick

update

get_geometry