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


proc assert { prop } {

  # Evaluate the given proposition in the calling context and die with an error
  # message if it's false.

  set p $prop
  set pattern {(.*)<([^:>]+)>:([0-9]+)(.*)}
  while { [ regexp $pattern $p _ pre lst idx post ] } {
    if { [ regexp {^[a-zA-Z0-9]$} $lst _ ] } {
      set lst "\$$lst"
      }
    set p "$pre\[lindex $lst $idx]$post"
    }

  if { ![ uplevel $p ] } {
    puts stderr "Assertion \"$prop\" failed."
    puts $errorInfo
    exit 1
    }
  }


proc max { a b } {

  # Return the larger of the given values.

  if { [ expr $a > $b ] } {
    return $a
    }
  return $b
  }


proc min { a b } {

  # Return the smaller of the given values.

  if { [ expr $a < $b ] } {
    return $a
    }
  return $b
  }


proc rint { max } {

  # Return a random integer in [0, max).

  return [ expr int($max*rand()) ]
  }


# $Log: utils.tcl,v $
# Revision 1.1  2003/09/01 18:36:19  rclayton
# Initial revision
#


# Local Variables:
# mode: tcl
# tcl-application: "tclsh"
# End:


proc clip-intervals { intervals y_max } {

  # Clip the given intervals to the upper and lower boundries of the page;
  # return the clipped segments.

  if { [ llength $intervals ] } {
    set i [ lindex $intervals 0 ]
    set i [ lreplace $i 0 0 [ min [ lindex $i 0 ] $y_max ] ]
    set intervals [ lreplace $intervals 0 0 $i ]

    set i [ lindex $intervals end ]
    set i [ lreplace $i 1 1 [ max [ lindex $i 1 ] 0 ] ]
    set intervals [ lreplace $intervals end end $i ]
    }

  return $intervals
  }


proc gen-figure { ht wd } {

  # Return a figure.

  set x [ expr double($wd)/2 ]
  set y [ expr double($ht)/2 ]

  return [ list \
	       [ list [ expr -$x ] $y ] \
	       [ list $x           $y ] \
	       [ list $x           [ expr -$y ] ]\
	       [ list [ expr -$x ] [ expr -$y ] ] ]
  }


proc get-edge { x y_max figures } {

  # Return an edge with the given x coordinate and passing through the given
  # figures.

  set intervals [ find-intervals $x $figures ]
  # puts stderr "find-intervals intervals = '$intervals'"
  set intervals [ merge-intervals $intervals ]
  # puts stderr "merge-intervals intervals = '$intervals'"
  # set intervals [ clip-intervals $intervals $y_max ]
  # puts stderr "clip-intervals intervals = '$intervals'"
  set intervals [ intify-intervals $intervals ]
  # puts stderr "intify-intervals intervals = '$intervals'"

  # puts stderr "get-edge edge = '$intervals'"

  return $intervals
  }


proc find-interval { x figure intervalref } {

  # Return the y coordinates of the intersection between the given figure and
  # the line with the given x coordinate.

  upvar $intervalref interval

  set interval { }
  set old_pt [ lindex $figure end ]

  # puts stderr "figure = '$figure'"

  foreach pt $figure {
    if { [ intersect $x $old_pt $pt y ] } {
      lappend interval $y
      }
    set old_pt $pt
    }

  # puts stderr "The intersection between x = $x and $figure is $interval."

  if { [ expr [ llength $interval ] == 0 ] } {
    return 0 
    }

  if { [ expr [ llength $interval ] == 2 ] } {
    return 1
    } 
  }


proc find-intervals { x figures } {

  # Return the y coordinates of the intersection between the given figure and
  # the line with the given x coordinate.

  set intervals { }

  foreach figure $figures {
    if { [ find-interval $x $figure interval ] } {
      lappend intervals $interval
      }
    }

  return $intervals
  }


proc find-segments { x figures } {

  # Return the list of line segments passing through the given figures and
  # having the given x coordinate.

  set segments { }
  foreach f $figures {
    set segment [ find-segment $x $f ]
    if { [ llength $segment ] } {
      lappend segments $segment
      }
    }

  return $segments
  }


proc intersect { x from to yref } {

  # Return the intersection point between the given line segment and the line
  # with the given x coordinate.

  upvar $yref y

  set x1 [ lindex $from 0 ]
  set x2 [ lindex $to 0 ]
  set y1 [ lindex $from 1 ]
  set y2 [ lindex $to 1 ]

  if { [ expr $x1 == $x2 ] } {
    if { [ expr $x1 == $x ] } {
      set y $y1
      return 1
      }
    return 0
    }

  if { [ expr (($x1 < $x2) && ($x1 <= $x) && ($x < $x2)) || \
	      (($x2 < $x1) && ($x2 < $x) && ($x <= $x1)) ] } {
    set alpha [ expr double($x - $x1)/double($x2 - $x1) ]
    set y [ expr ($y1 + ($y2 - $y1)*$alpha) ]
    return 1
    }

  return 0
  }


proc intify-intervals { intervals } {

  # Convert the given intervals to integer coordinates.

  for { set i [ expr [ llength $intervals ] - 1 ] } { $i >= 0 } { incr i -1 } {
    set interval [ lindex $intervals $i ]
    set y1 [ to_int [ lindex $interval 0 ] ]
    set y2 [ to_int [ lindex $interval 1 ] ]
    set intervals [ lreplace $intervals $i $i [ list $y1 $y2  ] ]
    }

  return $intervals
  }


proc list-reverse { lst } {

  # Return the given list reversed.

  if { ![ llength $lst ] } {
    return $lst
    }

  set e [ lindex $lst 0 ]
  set lst [ list-reverse [ lreplace $lst 0 0 ] ]
  lappend lst $e

  return $lst
  }


proc make-figure { x y ht wd } {

  # Return a figure.

  # puts stderr "ht = $ht, wd = $wd, x = $x, y = $y"
  set f [ gen-figure $ht $wd ] 
  set f [ scale-figure $f ]  
  set f [ rotate-figure $f ] 
  # puts stderr "f = '$f'"
  set f [ translate-figure $f $x $y ]
  # puts stderr "f = '$f'"

  return $f
  }


proc make_figures { ht wd } {

  # Return a list of figures on a page with the given dimension.

  set figures { }

  set fcnt [ expr 2 + [ rint 7 ] ]
  set fht  [ expr double($ht)/9 ]

  for { set i 0 } { $i < $fcnt } { incr i } {
    lappend figures [ make-figure [ expr double($wd)/2 ] [ expr (2*$i + 1)*$fht ]  $fht $wd ]
    }

  return $figures
  }


proc make_shreds { } {

  # Return a shredded document.

  set wd  8
  set ht 11

  set figures [ make_figures $ht $wd ]

  set delta [ expr [ rint 40 ] + 10 ]
  set strip_width [ expr double($wd)/double($delta) ]

  set shreds { }
  set old_edge [ get-edge 0 $ht $figures ]

  for { set i 1 } { $i <= $delta } { incr i } {
    set new_edge [ get-edge [ expr $strip_width*$i ] $ht $figures ]
    lappend shreds [ list $old_edge $new_edge ]
    set old_edge $new_edge
    }

  set shreds [ shuffle_shreds $shreds ]

  return $shreds
  }


proc merge-intervals { intervals } {

  # Return a segment list that 1) covers a point if and only if the point is
  # covered in the given segment list and 2) has the smallest number of
  # intervals possible.

  set intervals [ sort-intervals $intervals ]

  set new_intervals { }

  while { [ llength $intervals ] } {
    set interval [ lindex $intervals 0 ]
    set intervals [ lreplace $intervals 0 0 ]
    set ymax [ lindex $interval 0 ]
    set ymin [ lindex $interval 1 ]

    while { [ llength $intervals ] } {
      set interval [ lindex $intervals 0 ]
      set y1max [ lindex $interval 0 ]
      set y1min [ lindex $interval 1 ]
      if { [ expr $ymin > $y1max ] } {
	break;
        }
      set ymin [ min $ymin $y1min ]
      set intervals [ lreplace $intervals 0 0 ]
      }

    lappend new_intervals [ list $ymax $ymin ]
    }

  return $new_intervals
  }


proc output_edge { outf edge } {

  # Write the given edge to the given output file.

  if { [ llength $edge ] } {
    set sep ""
    foreach c $edge {
      puts -nonewline $outf $sep$c
      set sep " "
      }
    puts $outf ""
    } \
  else {
    puts 0
    }
  
  }


proc output_shreds { outf shreds } {

  # Write the given shreds to the given output file.

  set sep ""
  foreach shred $shreds {
    puts -nonewline $outf $sep
    set sep \n
    foreach edge $shred {
      output_edge $outf $edge
      }
    }
  }


proc reorient-shred { shred } {

  # Randomly turn and flip the given shred.

  if { [ rint 2 ] } {
    set shred [ list [ lindex $shred 1 ] [ lindex $shred 0 ] ]
    }

  if { [ rint 2 ] } {
    set l [ list-reverse [ lindex $shred 0 ] ]
    set r [ list-reverse [ lindex $shred 1 ] ]
    set shred [ list $l $r ]
    }

  return $shred
  }


proc rotate-figure { figure } {

  # Return the figure rotated.

  set angle [ expr 2*3.1415*(([ rint 20 ] - 10)/200.0) ]
  set cosa  [ expr cos($angle) ]
  set sina  [ expr sin($angle) ]

  set new_figure {}

  foreach p $figure {
    set x [ lindex $p 0 ]
    set y [ lindex $p 1 ]
    set p [ list [ expr $x*$cosa - $y*$sina] [ expr $x*$sina + $y*$cosa ] ]
    lappend new_figure $p
    }

  return $new_figure
  }


proc scale-figure { figure } {

  # Return a scaled copy of the given figure.

  set ht [ expr 1 + ([ rint 7 ] - 3.0)/10.0 ]
  set wd [ expr 1 + ([ rint 5 ] - 2.0)/10.0 ]

  set new_figure { }
  foreach p $figure {
    set x [ lindex $p 0 ]
    set y [ lindex $p 1 ]
    lappend new_figure [ list [ expr $x*$wd ] [ expr $y*$ht ] ] 
    }

  return $new_figure
  }


proc shuffle_shreds { shreds } {

  # Return the given shreds shuffled.

  set n [ llength $shreds ]

  for { set i [ expr $n + [ rint $n ] ] } { $i > 0 } { incr i -1 } {
    set j [ rint [ expr $n - 1 ] ]
    set s [ lindex $shreds $j ]
    set shreds [ lreplace $shreds $j $j ]
    lappend shreds $s
    }

  for { set i 0 } { $i < $n } { incr i } {
    set s [ reorient-shred [ lindex $shreds $i ] ]
    set shreds [ lreplace $shreds $i $i $s ]
    }

  return $shreds
  }


proc sort-intervals { intervals } {

  # Return the given interval list sorted in descending order by first
  # coordinate.

  for { set i [ expr [ llength $intervals ] - 1 ] } { $i > 0 } { incr i -1 } {
    set min   $i 
    set miny [ lindex [ lindex $intervals $min ] 0 ]
    for { set j [ expr $i - 1 ] } { $j >= 0 } { incr j -1 } {
      set y [ lindex [ lindex $intervals $j ] 0 ]
      if { [ expr $y < $miny ] } {
	set miny $y
	set min  $j
        }
      }
    set tmp [ lindex $intervals $i ]
    set intervals [ lreplace $intervals $i $i [ lindex $intervals $min ] ]
    set intervals [ lreplace $intervals $min $min $tmp ]
    }

  return $intervals
  }


proc strip-x { segments } {

  # Return only the y coordinates of the given segments.

  set new_segments { }
  foreach s $segments { 
    set y1 [ lindex [ lindex $s 0 ] 1 ]
    set y2 [ lindex [ lindex $s 1 ] 1 ]
    set s [ list [ max $y1 $y2 ] [ min $y1 $y2 ] ]
    lappend new_segments $s
    }
  
  return $new_segments
  }


proc TESTING { } {

  assert {expr [ llength [ sort-intervals { } ] ] == 0}

  set i { { 5 3 } { 7 5 } }
  set i [ sort-intervals $i ]
  assert {expr <<i>:0>:0 > <<i>:1>:0}

  set i { { { 2 5 } { 2 3 } } { { 2 5 } { 2 7 } } }
  set i [ strip-x $i ]
  assert {expr [ llength $i ] == 2}
  assert {expr <<i>:0>:0 == 5}
  assert {expr <<i>:0>:1 == 3}
  assert {expr <<i>:1>:0 == 7}
  assert {expr <<i>:1>:1 == 5}

  set i { { { 2 5 } { 2 3 } } { { 2 7 } { 2 5 } } }
  set i [ merge-intervals $i ]
  assert {expr [ llength $i ] == 1}
  assert {expr <<<i>:0>:0>:0 == 7}
  assert {expr <<<i>:0>:1>:0 == 3}

  set i { { { 2 3 } { 2 7 } } { { 2 4 } { 2 6 } } }
  set i [ merge-intervals $i ]
  assert {expr [ llength $i ] == 1}
  assert {expr <<<i>:0>:0>:0 == 7}
  assert {expr <<<i>:0>:1>:0 == 3}

  set i [ intersect 2 { 2 2 } { 2 4 } ]
  assert {expr [ llength $i ] == 2}
  assert {expr <i>:1 == 2}

  set i [ intersect 2 { 2 4 } { 2 2 } ]
  assert {expr [ llength $i ] == 2}
  assert {expr <i>:1 == 4}

  set i [ intersect 3 { 2 4 } { 2 2 } ]
  assert {expr [ llength $i ] == 0}

  set i [ intersect 2 { 4 4 } { 2 2 } ]
  assert {expr [ llength $i ] == 0}

  set i [ intersect 3 { 4 4 } { 2 2 } ]
  assert {expr [ llength $i ] == 2}
  assert {expr <i>:1 == 3}

  set i [ intersect 4 { 4 4 } { 2 2 } ]
  assert {expr [ llength $i ] == 2}
  assert {expr <i>:1 == 4}

  set i { { 0 2 } { 2 2 } { 2 4 } }
  set i [ find-segment 2 $i ]
  assert {expr [ llength $i ] == 2}
  assert {expr ([ expr <<i>:0>:1 == 2 ] && [ expr <<i>:1>:1 == 4 ]) || \
               ([ expr <<i>:1>:1 == 2 ] && [ expr <<i>:0>:1 == 4] ) }

  set i { { 0 2 } { 2 2 } { 2 4 } }
  set i [ find-segment 1 $i ]
  assert {expr [ llength $i ] == 2}
  assert {expr ([ expr <<i>:0>:1 == 2 ] && [ expr <<i>:1>:1 == 3 ]) || \
               ([ expr <<i>:1>:1 == 2 ] && [ expr <<i>:0>:1 == 3 ] ) }
  }


proc to_int { x } {

  # Return the given number rounded to the nearest int.

  return [ expr round(10*$x + 0.5) ]
  }


proc translate-figure { figure x y } {

  # Return the figure translated.

  # puts stderr "x = $x, y = $y"

  set deltay [ expr (1.0 + ([ rint 7 ] - 3)/10.0)*$y ]
  set deltax [ expr (1.0 + ([ rint 7 ] - 3)/10.0)*$x ]
  set deltax $x
  set deltay $y

  set new_figure {}

  foreach p $figure {
    set x [ lindex $p 0 ]
    set y [ lindex $p 1 ]
    set p [ list [ expr $x + $deltax] [ expr $y + $deltay ] ]
    lappend new_figure $p
    }

  return $new_figure
  }


output_shreds stdout [ make_shreds ]


# Local Variables:
# mode: tcl
# tcl-application: "tclsh"
# End: