#!/bin/sh
 # Restart with tcl: -*- mode: tcl; tab-width: 8; -*- \
 exec wish $0 ${1+"$@"}

 ##+##########################################################################
 #
 # Hack-O-Matic -- visual binary editor
 # by Keith Vetter, September 2003
 #
 # Rob Kudla on https://wiki.tcl-lang.org/9505 complained about a utility for
 # editing Atari graphic files called Hack-O-Matic, that he wrote in
 # tcl was 10 times slower than a windows BASIC version and unstable.
 #
 # Taking that as a challenge, here's a version I wrote in a few hours
 # that is quite fast.

 # The speed up was not in nit-picking optimizations like bracing
 # expressions but in a new algorithm. I don't care what language
 # you're using but if you have a 32k file, drawing 32k * 8 boxes is
 # going to take a long time. Instead, just draw as many boxes as will
 # fit on the screen. The scrollbar command, instead of scrolling
 # pixels, just changes which rows get displayed.

 package require Tk

 set S(title) "Hack-O-Matic"
 set S(box) 20                                   ;# Size of each cell
 set S(tm) 10                                    ;# Top margin
 set S(lm) 10                                    ;# Left margin
 set S(lm2) 45                                   ;# Left margin for the grid
 set S(rows) 16                                  ;# How many rows to show
 set S(max) 1048576                              ;# Largest file we can handle
 set S(top) 0                                    ;# First row of data to display

 proc DoDisplay {} {
    global S

    wm title . $S(title)

    menu .menu
    . configure -menu .menu                      ;# Attach menu to main window
    .menu add cascade -menu .menu.file -label "File" -underline 0
    .menu add cascade -menu .menu.help -label "Help" -underline 0

    menu .menu.file
    menu .menu.help
    .menu.file add command -label "Open" -command LoadFile
    .menu.file add command -label "Save As..." -command SaveFile
    .menu.file add command -label "Exit" -command exit
    .menu.help add command -label "About..." -command About

    label .title -textvariable S(fname) -bd 2 -relief sunken
    scrollbar .sb -orient vertical -command ScrollProc
    canvas .c -width 245 -highlightthickness 0
    .c config -height [expr {$S(tm) + $S(rows)*$S(box)}]

    pack .title -side top -fill x
    pack .sb -fill y -expand 0 -side right
    pack .c -fill both -expand 1 -side left

    for {set i 0; set n 1} {$i < 8} {incr i} {
        set ::S(pow,$i) $n
        set n [expr {2*$n}]
    }
    # update
    bind .c <Configure> {Resize %W %h %w}       ;# Handle resizing
 }

 #
 # ScrollProc -- called by the scrollbar. We need to determine what
 # the new top of the page is.
 #
 proc ScrollProc {args} {
    foreach {cmd perc} $args break
    if {$cmd != "moveto"} return
    set top [expr {round($perc * $::DATA(len))}]
    if {$top == $::S(top)} return
    DoPage $top
 }
 #
 # DoPage -- display a screenful of data rows starting at TOP
 #
 proc MkPage {} {
    global S DATA
    .c delete all
        puts "Make $S(rows)"
    for {set i 0} {$i < $S(rows)} {incr i} {
        MkRow $i
    }

 }

 proc MkRow {srow} {
    global S DATA


    set x1 $S(lm2)
    set x2 [expr {$x1 + $S(box)}]
    set y1 [expr {$S(tm) + $S(box) * $srow}]
    set y2 [expr {$y1 + $S(box)}]
    set ym [expr {$y1 + $S(box)/2}]

    .c create text $S(lm) $ym -tag d$srow -text ???? -anchor w

    foreach i  {7 6 5 4 3 2 1 0} {
        set tag b$srow,$i
        set xy [list $x1 $y1 $x2 $y1 $x2 $y2 $x1 $y2]
        .c create poly $xy -tag [list b$srow $tag] \
            -fill white -outline black
        .c bind $tag <Button-1> [list CellClick $srow $i $srow]
        set x1 $x2
        incr x2 $S(box)
    }

    # Show the hex value and the character
    .c create text $x1 $ym -tag e$srow -text ???? -anchor w
 }

 proc DoPage {{top ""}} {
    global S DATA

    if {$top == ""} {set top $S(top)}
    set S(top) $top

    for {set i 0} {$i < $S(rows)} {incr i} {
        DoRow [expr {$S(top) + $i}] $i
    }

    # Adjust the scrollbar
    set sb1 [expr {double($S(top)) / $DATA(len)}]
    set sb2 [expr {double($S(top)+$S(rows)) / $DATA(len)}]
    .sb set $sb1 $sb2
 }
 #
 # DoRow -- shows one row of data at a given screen row
 #
 proc DoRow {row srow} {
    global S DATA

    if {$row >= $DATA(len)} return
    set datum [lindex $DATA(bytes) $row]

    set x1 $S(lm2)
    set x2 [expr {$x1 + $S(box)}]
    set y1 [expr {$S(tm) + $S(box) * $srow}]
    set y2 [expr {$y1 + $S(box)}]
    set ym [expr {$y1 + $S(box)/2}]

    set num [format %04x $row]
        .c itemconfig d$srow -text $num 

    for {set i 7} {$i >= 0} {incr i -1} {
        set tag b$srow,$i
        set xy [list $x1 $y1 $x2 $y1 $x2 $y2 $x1 $y2]
        .c itemconfig $tag -fill [expr {$datum & $S(pow,$i) ? "black" : "white"}]
        set x1 $x2
        incr x2 $S(box)
    }

    # Show the hex value and the character
    set ch [format %c $datum]
    if {! [string is ascii $ch] || [string is control $ch]} {set ch "?"}
    set extra [format " %02x %s" [expr {($datum + 0x100) % 0x100}] $ch]
    .c itemconfig  e$srow -text $extra
 }
 #
 # CellClick -- handles clicking in a cell which toggles the bit
 #
 proc CellClick {row col srow} {
    global S DATA

    set datum [lindex $DATA(bytes) $row]
    if {$datum & $S(pow,$col)} {                ;# Bit is already set
        .c itemconfig b$srow,$col -fill white
        incr datum -$S(pow,$col)
    } else {                                    ;# Bit is off
        .c itemconfig b$srow,$col -fill black
        incr datum $S(pow,$col)
    }
    lset DATA(bytes) $row $datum

    set ch [format %c $datum]
    if {! [string is ascii $ch] || [string is control $ch]} {set ch "?"}
    set extra [format " %02x %s" [expr {($datum + 0x100) % 0x100}] $ch]
    .c itemconfig e$srow -text $extra
 }
 #
 # LoadFile -- reads a file and converts to an integer list
 #
 proc LoadFile {{fname ""}} {
    global S DATA

    # Read in the data
    if {$fname == ""} {
        set fname [tk_getOpenFile]
        if {$fname == ""} return
    }
    if {[file size $fname] >= $S(max)} {
        tk_messageBox -message "File $fname is too big" -icon error
        return
    }

    set S(fname) [file tail $fname]
    set FIN [open $fname r]
    fconfigure $FIN -translation binary
    set bytes [read $FIN [file size $fname]]
    close $FIN

    binary scan $bytes c* DATA(bytes)
    set DATA(len) [llength $DATA(bytes)]
    DoPage 0
 }
 #
 # SaveFile -- saves our binary data
 #
 proc SaveFile {} {
    global DATA

    set fname [tk_getSaveFile]
    if {$fname == ""} return

    set FOUT [open $fname w]
    fconfigure $FOUT -translation binary
    puts -nonewline $FOUT [binary format c* $DATA(bytes)]
    close $FOUT
 }
 proc About {} {
    tk_messageBox -message "$::S(title)\nby Keith Vetter, September 2003" \
        -title "About $::S(title)"
 }
 proc Resize {W h w} {
    global S

    if {$W != ".c"} return
    set rows [expr {1 + int(([winfo height .c] - $S(tm)) / $S(box))}]
    if {$rows == $S(rows)} return
    set S(rows) $rows
    MkPage
        DoPage
 }

 DoDisplay

 proc test {} {

        for {set i 0} {$i < 1000} {incr i} {
        DoPage $i
        update idletasks
        }

 }

 set script [info script]
 if {[file readable $script]} {                  ;# Use this script as a demo
    LoadFile $script
        ### PWQ Time to scroll 1000 lines.
        update
        set x [time test]
        puts "Time $x"
 } else {
    set txt "$S(title)\nby Keith Vetter"        ;# Sample text to display
    binary scan $txt c* DATA(bytes)
    set DATA(len) [llength $DATA(bytes)]        ;# Rows of data to display
    DoPage 0
 }