#!/bin/sh
# In sh check to see if the "--o" argument is present.
# If it is, run tclsh, otherwise, run wish.
# (The backslash makes the following line a comment as well... \
THESH="wish"
# blah\
for arg in "$@" ; do if [ "$arg" == "--o" ] ; then THESH="tclsh" ; fi ; done ; \
# \
exec $THESH "$0" "$@"

#  Boust:
#    a tcl/tk text reader that formats the text boustrophedon.
#
#  Version 0.14
#  Last modified 2001.11.12
#
#
#  AUTHOR: Simmon Keith Barney <boust@traevoli.com>
#
#  This program is free software; you can redistribute it and/or
#  modify it under the terms of the GNU General Public License
#  as published by the Free Software Foundation; either version 2
#  of the License, or (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program (look for the file COPYING); if not, write to
#  the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139,
#  USA.

set Version "0.14"
set contents ""
set ft ""
set lines ""
set words ""
set everything ""
set maxX 60
set maxY 20
set x 0
set y 1
set psline 1
set direction 1
set left $maxX
set iscolor 0
set print 0
set printFile boust_out.ps
set prnOut ""
set pagew 612
set pageh 792
set lrmargin 60
set tbmargin 60
#set psfontsize [expr [expr [expr $pagew - $lrmargin - $lrmargin]/ $maxX] * 1.666666667]
#set psfontsize 14
set Pages 1
set check ""
set lastcheck ""
set printOnly 0
set userfontsize "unspecified"

set fwfont 10x20-iso8859-forwards
set bwfont 10x20-iso8859-backwards
set fwc #c0ffd0
set bwc #ffffd0

set printhelp "
boust \[--h --o --cpl --pw --ph --lr --tm --f\] \[input_file\]
                                            (defaults to README)
  --h     this help screen

  --o \[filename\] ps output file (or - for stdout)
   	             inhibits loading of tk interface
  --cpl # 	    characters per line (default 60)
  --pw  # 	    page width* 	(default 612)
  --ph  # 	    page height*        (default 792)
  --lr  # 	    left-right margin*  (default 60)
  --tb  # 	    top-bottom margin*  (default 60)
  --f   # 	    font size 	        (precalculated)

     * - in 72nds of an inch
"

if {[llength $argv] > 0} {
   set para $argv

   #Quit if any of the parameters ask for help
   foreach p $para {
     if {$p == "--h" | $p == "--help"} {
       puts stderr $printhelp 
       exit
     }
   }

   #Every parametere (except --h) should have a value.  So we can assume
   #that if there's an odd number, there's a file specified
   while {[llength $para] > 1} {
   	 #puts stderr "[lindex $para 0] [lindex $para 1]"
	 
	 set parameter [lindex $para 0]
	 set value [lindex $para 1]
	 
	 switch -exact -- $parameter {
	   --o { set printFile $value; set printOnly 1; }
	   --cpl {set maxX $value;}
	   --pw {set pagew $value;}
	   --ph {set pageh $value;}
	   --lr {set lrmargin $value;}
	   --tb {set tbmargin $value;}
	   --f { set userfontsize $value; }
	 }
	 
	 #Chop off the first two parameters
  	 set para [lrange $para 2 [expr [llength $para]-1]]
   }
   if {[llength $para] == 1} {
       set fileName [lindex $para 0]  
   } else {
     puts stderr "No file specified.  Defaulting to 'README'.  "
     set fileName README
   }


} else {
  puts stderr "No file specified.  Defaulting to 'README'.  "
  set fileName README
}

if {$printOnly == 0} {
#tk interface initialization
wm title . "Boust Version $Version"
frame .top
frame .bottom
frame .aboveb
pack .top -side top -expand true -fill both
pack .bottom -side bottom -fill x -expand false
pack .aboveb -side bottom -fill x -expand false
text .read -width $maxX -height $maxY -relief sunken -setgrid true \
	-yscrollcommand ".yscrollbar set" -font $fwfont
scrollbar .yscrollbar -command ".read yview"
pack .yscrollbar -side right -fill y -in .top -expand false
.read tag configure fw -font $fwfont
.read tag configure bw -font $bwfont
.read tag configure fwcolor -background $fwc
.read tag configure bwcolor -background $bwc
pack .read -side right -fill both -expand true -in .top
button .quit -text Quit -command quit_dialog
button .reformat -text Reformat -command {
  set direction 1
  .read delete 0.0 end
    if {[string length $ft] > 0} {postformat}
}
button .reload -text Reload -command {
  set direction 1
  set Pages 1
  .read delete 0.0 end
  main
}
checkbutton .coloron -text "On/Off" -variable iscolor -command {
	.reformat invoke}
button .print -text "Print" -command {
	print_options
}
entry .fwcolor_entry -textvariable fwc
entry .bwcolor_entry -textvariable bwc
label .fwcolor_label -text Color:
label .bwcolor_label -text Color:
pack .fwcolor_entry -in .aboveb -side right
pack .fwcolor_label -in .aboveb -side right
pack .bwcolor_entry -in .aboveb -side right
pack .bwcolor_label -in .aboveb -side right
pack .coloron -in .aboveb -side right
pack .print -in .aboveb -side left
pack .quit -in .bottom -side right
pack .reformat -in .bottom -side right 
pack .reload -in .bottom -side right
label .status 
label .entry_label -text File:
entry .filename_entry -textvariable fileName
pack .status -side left -in .bottom
pack .filename_entry -side right -in .bottom 
pack .entry_label -side right -in .bottom

focus .yscrollbar

bind . <Prior> {.read yview scroll -1 page}
bind . <Next> {.read yview scroll 1 page}
bind . <Up> {.read yview scroll -1 units}
bind . <Down> {.read yview scroll 1 units}
bind .read <FocusIn> {focus .}
bind .filename_entry <Return> {.reload invoke}
bind .fwcolor_entry <Return> {
	.read tag configure fwcolor -background $fwc
	.read tag configure bwcolor -background $bwc
	if { $iscolor} {.reformat invoke}
     }
bind .bwcolor_entry <Return> {
	.read tag configure fwcolor -background $fwc
	.read tag configure bwcolor -background $bwc
	if {$iscolor} {.reformat invoke}
     }
bind . <Escape> {quit_dialog}
bind .read <Configure> {reset_geometry}

proc quit_dialog {} {
  toplevel .quit_dialog
  wm title .quit_dialog {Really Quit?}
  label .quit_dialog.areyousure -text {Do You Really Want To Quit?}
  button .quit_dialog.yes -text Yes -command exit
  button .quit_dialog.no -text No -command "destroy .quit_dialog"
  
  pack .quit_dialog.areyousure -side top 
  pack .quit_dialog.yes -side left
  pack .quit_dialog.no -side right
  bind .quit_dialog <Escape> {destroy .quit_dialog}
  bind .quit_dialog <Return> {exit}

  #puts stderr [winfo geometry .quit_dialog]
 
  set mousex [winfo pointerx .] 
  set mousey [winfo pointery .] 
  #set offsetx [expr [winfo width .quit_dialog] /2]
  #set offsety [expr [winfo height .quit_dialog] /2]
  #I can't get the geometry of the window I'm creating!
  #Static values will have to do for now.
  set offsetx 170
  set offsety 65
  set quitx [expr $mousex - $offsetx]
  set quity [expr $mousey - $offsety]

  wm geometry .quit_dialog +$quitx+$quity
  } ;#end printOnly
} ;#end tk interface initialization

proc print_options {} {
global psfontsize
global pagew
global pageh
global lrmargin
global tbmargin
global Pages
global maxX

  toplevel .print_dialog
  wm title .print_dialog {Printing Options}
  frame .print_dialog.top
  frame .print_dialog.bottom
  pack .print_dialog.top -side top -expand true -fill both
  pack .print_dialog.bottom -side bottom -expand false -fill x
  label .print_dialog.titleText -text {Printing Options}
  button .print_dialog.print -text Print -command {print
	  destroy .print_dialog
	  #.reformat invoke
	}
  button .print_dialog.cancel -text Cancel -command {destroy .print_dialog
	}
  entry .print_dialog.print_file -textvariable printFile
  pack .print_dialog.print_file -in .print_dialog.top -side left
  pack .print_dialog.print -in .print_dialog.top -side left
  pack .print_dialog.cancel -in .print_dialog.top -side right
  entry .print_dialog.pagew -textvariable pagew
  entry .print_dialog.pageh -textvariable pageh
  entry .print_dialog.size -textvariable psfontsize
  entry .print_dialog.lrmargin -textvariable lrmargin
  entry .print_dialog.tbmargin -textvariable tbmargin
  label .print_dialog.pagew_label -text "Page Width:"
  label .print_dialog.pageh_label -text "Page Height:"
  label .print_dialog.size_label -text "Font Size:"
  label .print_dialog.lrmargin_label -text "Left-Right Margin:"
  label .print_dialog.tbmargin_label -text "Top-Bottom Margin:"
  pack .print_dialog.pagew_label
  pack .print_dialog.pagew
  pack .print_dialog.pageh_label
  pack .print_dialog.pageh
  pack .print_dialog.lrmargin_label
  pack .print_dialog.lrmargin
  pack .print_dialog.tbmargin_label
  pack .print_dialog.tbmargin
  pack .print_dialog.size_label
  pack .print_dialog.size

  bind .print_dialog.print_file <Return> {.print_dialog.print invoke}
  bind .print_dialog <Escape> {.print_dialog.cancel invoke}
}


proc reset_geometry {} {
global maxX
global maxY
global direction
global psfontsize
#global .status


  set geometry [split [wm geometry .] x+]
  #puts $geometry
  set maxX [lindex $geometry 0]
  set maxY [lindex $geometry 1]
  setpsfontsize
  set direction 1
  set Pages 1
  .read delete 0.0 end
  postformat
    
};#end reset_geometry

proc main {} {

global printOnly
global ft
global argv
global maxX
global maxY
global left
if {$printOnly == 0} {
  global .read
  global .yscrollbar
}
global fileName

global contents; set contents {}
set filecontents {}
set file_error 0

if {$fileName != "-"} {
  if {[catch {open $fileName} fileId]} {
    set file_error 1
  }
} 

if {$file_error} {
   set file_error 0
   puts stderr "Error:  $fileId"
  if {$printOnly == 0} {
    .read insert end "Error:  $fileId"
  }  
} else {

   if {$printOnly == 0} {
     .status configure -text "Loading..."
      update
   }
  #read and process file
  if {$fileName != "-" } {
    set thefile [open $fileName r]
  } else {
    set thefile stdin
  }
  set filecontents "[read $thefile] \n"

        #puts "preformat begin"
#       Begin Preformat section

# Remove all \r (carriage return)
regsub -all "\r" $contents "" contents

# Remove all \n that don't make a paragraph
regsub -all "\n(\[^(\n\t*|\n(    +)*|\t|   +)])" \
        $filecontents { \1} contents

#Remove all whitespace at beginning of paragraph
regsub -all "(^|\n)\[ \t]+" $contents {\1} contents

#Replace all remaining tabs with a space
regsub -all "\t" $contents " " contents
 
#Replace multiple instances of spaces with single space
regsub -all " +" $contents " " contents

#Replace whitespace that occurs just before a newline
regsub -all " \n" $contents "\n" contents

#Replace all multiple returns with single return
regsub -all "\n\n*" $contents "\n" contents

#       End PreFormat section
        #puts "preformat end"

if {$fileName != "-"} {
  close $fileId
}
} ;# end of if else

if {$printOnly == 1} {
  setpsfontsize
  print
  exit
} else {
  postformat
}

} ;# end Main

proc print {} {

global printOnly
global Version
global print
global direction
global printFile
global prnOut
set direction 1
global psfontsize
global pagew
global pageh
global lrmargin
global tbmargin
global Pages 

if {$printFile == "-"} {
  set prnOut stdout
} else {
  if [catch {open $printFile w} prnOut] {
     puts stderr "Error:  $prnOut"
     if {$printOnly == 0} {
       .read insert end "Error:  $prnOut"
     }
     return 0
  } else {
      set prnOut [open $printFile w]
  }

  if {$printOnly == 0} {
    .status configure -text "Printing..." 
  }
}

fconfigure $prnOut -buffering line

set ps_header "%!PS-Adobe-2.0
%%PageOrder: Ascend   
%%BoundingBox: 0 0 $pagew $pageh
%%Creator: boust.tcl Version $Version
%define variables & procedures
/size $psfontsize def  
/pagew $pagew def
/pageh $pageh def
/lrmargin $lrmargin def
/tbmargin $tbmargin def
/lm lrmargin def
/rm pagew lrmargin sub def
/tm pageh tbmargin sub size sub def
/bm tbmargin def
/myfont /Courier def
/nextline {0 -1 size mul rmoveto} def

/forward {myfont findfont
size scalefont
\[ 1 0 0 1 1 0 \] makefont
        setfont} def
/backward {myfont findfont
size scalefont
\[ -1 0 0 1 1 0 \] makefont
        setfont} def\n
%init
%%Page: 1
newpath 
lm tm moveto
0 0 0 setrgbcolor\n
%put text\n"

puts $prnOut $ps_header

set print 1
postformat
set print 0
puts $prnOut "\n%done\nshowpage\n%%Pages: $Pages"
if {$prnOut == "stdout"} {
   flush $prnOut
} else {
  close $prnOut
}
if {$printOnly == 0} {
  .status configure -text "Done."
}
#.reformat invoke
} ;#end of print

proc NewPage {} {

global pageh
global tbmargin
global lrmargin
global psfontsize
global Pages
global prnOut
global psline
global x
global maxX
global left
global direction

set psx $x

#  puts $prnOut "
#  newpath
#  lm tm moveto
#  rm tm lineto
#  rm bm lineto
#  lm bm lineto
#  lm tm lineto
#  stroke
#  "


 #puts $prnOut "save"
  puts $prnOut "showpage"	  	  
  set psline [expr $pageh - $tbmargin - $psfontsize ]
  incr Pages
  puts $prnOut "%%Page: $Pages"
  puts $prnOut "newpath"
  
 #puts $prnOut "restore\ncurrentpoint pop tm moveto"

  if {$direction == 1} {
    puts $prnOut "lm tm moveto"
  } else {
    puts $prnOut "rm tm moveto"
  }
}

proc postformat {} {
global direction
global contents
global ft
global maxX
global left
global lines
global words
global everything
global y
global psline
global x
global printOnly
if {$printOnly == 0} {
  global .read
}
global print
global printFile
global prnOut
global psfontsize
global pagew
global pageh
global lrmargin
global tbmargin
global Pages

set Pages 1

  #puts "postformat"
if {$printOnly ==0} {
  .status configure -text "Formatting..."
}

set psline [expr $pageh - $tbmargin - $psfontsize ]
set y 1
set x 0
set ft $contents
set par 0
set word 0
set left $maxX
set lines ""
set words ""
set everything ""
set count 0

set ft [split $ft "\n"]
 
#puts "\[lindex \$ft 1] = [lindex $ft 1]"
#puts "\[lindex \[lindex \$ft 0] 1] = [lindex [lindex $ft 0] 1]"

set par 0
set word 0

# scott code
#puts "start postformat foreach"
  foreach paragraph $ft {
      set words [split $paragraph]
      foreach word $words {
          lappend everything $word
      }
      lappend everything "\n"
  }
#puts "end postformat foreach"
# end scott code

# my buggy code
#
#   while {[lindex $ft $par] != ""} {
#	while {[lindex [lindex $ft $par] $word] != ""} {
#	   lappend words [lindex [lindex $ft $par] $word]
#	   incr word
#	}
#	lappend words "\n"
#	incr par
#	set word 0
#   }
#
# end my buggy code

#puts "start postformat while loop"
set word 0
set output ""
set output2 ""
set outputlength 0
set left $maxX
set size 0
set spacechar " "
set count2 0

while {[lindex $everything $word] !=""} {
#puts stderr "while loop"

global check
global lastcheck

  set lastcheck $check
  set check [lindex $everything $word]

  if {$check == "\n"} {
  #if it's a new paragraph
  #puts stderr "new paragraph"
	update
	#puts  "\\n"
	  for {set i 0} {$i < $left} {incr i} {
		append output $spacechar
	  }
	  write_line $direction $output
	  set output ""	
	  incr y
	  if {$print} {
	    #incr psline [expr $psfontsize * -1]
	    set psline [expr $psline + [expr $psfontsize * -1.0] ]
	    #if {$psline <= $tbmargin } {
	    #  NewPage
	    #}
	  }
	  incr word

      #Check to see if the word is short enough to fit on the line.
      if {[string length [lindex $everything $word]] > $left | \
	$left < [expr $maxX * .1]} {
	      #If not:
	      	  #puts stderr "Too long first way"
	     
	     #If it's too long for the other way, it'll see which direction
	     #provides the most room for the word.
	     if {[whichfit $word] != 0 } { 
	       set nonflipped [expr [string length [lindex $everything $word]] - $left]
	       set flipped [expr [string length [lindex $everything $word]] - $maxX - $left -1]
	       set fits 0
	     } else {
	       #if it fits
	       set fits 1
	       set flipped 0
	       set nonflipped 1
	     }
	     
	     if {$fits == 0 | $flipped > $nonflipped} {
	     #If the word fits, or the other directions fits more characters
	     #it'll turn around, and add the word.
	        #puts stderr "flipped direction."	     		
	      set fits 0
	        
	        set direction [expr $direction * -1]
		for {set i 0} {$i <= $left} {incr i} {
			append output $spacechar
	  	}
		set left [expr $maxX - $left]
		incr left -1	
				
		if {$print} {
		  puts $prnOut "nextline"
		} else {
		  if {$printOnly == 0} {
		    .read insert end "\n"
		  }
		}
		incr y
		if {$print} {
		  #incr psline [expr $psfontsize * -1]
		  set psline [expr $psline + [expr $psfontsize * -1.0] ]
		  if {$psline <= $tbmargin } {
		    NewPage
		  }
		}
		  #Now, hyphenate the word.
		  hyphenate $word

	      }

	  } else {
	    #If it does fit, put it on the line.
	    #(Doesn't this just add buffer space to previous and next lines?
	    # Leaving the word in the 'queue' for the next iteration to handle?)
		for {set count 0} {$count < $maxX} {incr count} {
		  append output2 $spacechar
		}	
		write_line [expr $direction * -1] $output2
		set output2 ""

		for {set i 0} {$i < [expr $maxX - $left]} {incr i} {
			append output $spacechar
	  	}		
		incr y
		if {$print} {
		  #incr psline [expr $psfontsize * -1]
		  set psline [expr $psline + [expr $psfontsize * -1.0] ]
		  if {$psline <= $tbmargin } {
		    NewPage
		  }
		}
	  } 


  } else {
  #If it's not a new paragraph:
  #puts stderr "normal word"
	
	set size [expr [string length [lindex $everything $word]] +1]

	if {$size <=$left} {
	    # I dunno if this'll work...
	    if {$direction == 1} {
		incr x [expr $size -1]
	    } else {
		incr x [expr [expr $size -1] * -1]
	    }
	    #
	  append output "[lindex $everything $word] "
	  incr word
	  incr left [expr $size * -1]
	} else {
	#If the word's too long to fit on the line...
	
	#TODO:
	#Here I think I'll check it's length.  If it's really long, even if
	#it fits the other way, it may be better to hyphenate.  I dunno.

          if { [whichfit $word] != 0 } {
	   #If it's too long for the other way, it'll hyphenate, 
	   hyphenate $word
	  } else {
	  #otherwise it'll turn around, and add the word.
	  
	  #otherwise, turn around, and add the word.
	  #puts stderr "flipped direction"
	    
	    if {$lastcheck != "\n"} {
	      for {set i 0} {$i < $left} {incr i} {
		append output $spacechar
	      }
	    }
	    write_line $direction $output
	    set output ""
	    for {set i 0} {$i <= $left} {incr i} {
		  append output $spacechar
	    }
	    set left [expr $maxX - $left]
	    incr left -1
	    incr y
	    set direction [expr $direction * -1]
	    if {$print} {
	      #incr psline [expr $psfontsize * -1]
	      set psline [expr $psline + [expr $psfontsize * -1.0] ]
	      if {$psline <= $tbmargin } {
	  	  NewPage
	      }
	    }
	  }

       }
   }

} ;#end while-there's-still-data
#puts "Processed $word words."
#puts "end postformat while loop"

#.read insert end $everything

if {$printOnly == 0} {
  .status configure -text "Done."
}  
#puts "end postformat"
} ;# end of postformat

proc write_line {direction text} {
global x
global y
global psline
global printOnly
if {$printOnly == 0} {
  global .read
}
global maxX
global left
global iscolor
global print
global printFile
global prnOut


	#regsub -all " \$" $text "" text
	#regsub -all "\^ " $text "" text
 if { $print } {
	regsub -all {\(} $text {\\(} text
	regsub -all {\)} $text {\\)} text
	#You need to make sure to espace-protect ()'s
	#	as well as OTHER special characters of PostScript
	#	like % or \, etc...
  if { $direction > 0} {
    puts $prnOut "forward\n($text) show\nnextline"
  } else {
    puts $prnOut "backward\n($text) show\nnextline"
  }
 } else { 
#display text instead

  if { $direction > 0} {
    .read insert end "$text\n"	;#print a line here
    .read tag add fw $y.0 $y.end	;#set_font forward
    if { $iscolor } {
	.read tag add fwcolor $y.0 $y.end}
  } else {
    set text [reverse "$text"]
    .read insert end "$text\n"	;#print a line here
    .read tag add bw $y.0 $y.end	;#set_font backward
    if { $iscolor } {
    	.read tag add bwcolor $y.0 $y.end}
  }
 } 
# end if print

} 
# end write_line

proc reverse {text} {
set reversed ""
set end [string length $text]
set count [expr $end -1]

while {[string index $text $count] != ""} {
append reversed [string index $text $count]
incr count -1
}
return $reversed

} ;#end reverse

proc whichfit {word} {

  global maxX
  global left
  global everything

  if {[string length [lindex $everything $word]] > [expr $maxX - $left -1]} {
    #If it doesn't fit
    return [string length [lindex $everything $word]];
  } else {
    #If it fits
    return 0;
  }
} ;#end whichfit  

proc hyphenate {word} {

  global maxX
  global left
  global everything

    #cut it in two, adding the neccessary hyphen
    
    set theword [lindex $everything $word]
    set thesize [string length $theword]
    #set cutoff [expr $thesize/2]
    set cutoff [expr $left - 3]
#    set firsthalf [string range $theword 0 [expr $thesize/2 -1] ]
    set firsthalf [string range $theword 0 $cutoff ]
    if {[string index $firsthalf end] != "-"} {
      set firsthalf "$firsthalf-"
    }
#    set secondhalf [string range $theword [expr $thesize/2 ] $thesize ]
    set secondhalf [string range $theword [expr $cutoff+1] $thesize]
    if {[string index $secondhalf 0] == "-"} {
      set secondhalf [string range $secondhalf 1 end]
    }
    
    #puts stderr "Whole: \"$theword\", First: \"$firsthalf\", Second: \"$secondhalf\""

    #Then change the word to the first half, and insert the second half
    set everything [lreplace $everything $word $word $firsthalf]
    set everything [linsert $everything [expr $word + 1] $secondhalf]
    
} ;#end hyphenate

proc setpsfontsize {} {

 global psfontsize
 global pagew
 global lrmargin
 global maxX
 global userfontsize
 
 #Note:  This formula -- however it works -- is for fixed-width fonts only.
 #       Perhaps only courier...
  if {$userfontsize == "unspecified"} {
    set psfontsize [expr [expr double([expr $pagew - $lrmargin - $lrmargin])/ $maxX] * 1.666666667]
  } else {
    set psfontsize $userfontsize
  }
}

#run Main 
main



#Add event-based stuff:
#	If the window is resized:
#	  * clear textbox:  [.read delete 0.0 end]
#	  * postformat









