Require bind.tcl
Require Class/basicPolyhedron

basicPolyhedron Subclass basicArrows {
  ClassVar arrows

  Method Compute {} {
    uplevel [list Self MakeArrows [val arrows]]
    uplevel Self Recolor
  }

  Method MakeArrows {arrows} {
    Vars F; set F {}
    set MakeArrow [Self method MakeArrow]
    set MakeFace  [Self method MakeFace]

    foreach data $arrows {
      set head [lindex $data 3]
      set a [lindex $data 0]
      if {[llength $a] != 2} \
        {Error "Arrow '$a' has the wrong number of points (must be 2)"}
      foreach face [eval $MakeArrow $a $head] \
        {lappend F [lreplace $data 0 0 $face]}
    }
  }

  Method MakeArrow {p q {h ""} {w ""} {r ""}} {
    Vars hlength hwidth hrelative scale maxlen keep
    if {$h == ""} {set h $hlength}
    if {$w == ""} {set w $hwidth}
    if {$r == ""} {set r $hrelative}

    set P [- $q $p]
    set len [Norm $P]
    set s [_expr(Math) $scale]
    set len [expr $s*$len]
    if {$maxlen > 0 && $len > $maxlen} {
      if {!$keep} return
      set len $maxlen
      set s [expr double($maxlen)/$len]
    }
    if {$s != 1} {set P [* $s $P]; set q [+ $p $P]}
    
    if {$h == 0 || $w == 0} {
      return [list [list $q $p]]
    } else {
      set u [Unit $P]
      set z [* 0 $u]
      if [=== [expr abs([lindex $u 0])] 1] {
        set n [lreplace $z 1 1 1]
      } else {
        set n [lreplace $z 0 0 1]
        set n [Unit [- $n [* [Dot $n $u] $u]]]
      }
      if {$r} {set w [_expr(Math) $w*$len]; set h [_expr(Math) $h*$len]}
      set n [* $w $n]; set l [- $q [* $h $u]]
      return [list [list $p $l] [list $q [+ $l $n] [- $l $n]]]
    }
  }

  Method VFdata {actions} {
    upvar data data; set i 0
    switch [lindex $actions 0] {
      head {
        set head [lindex $actions [incr i]]
        if {$head == ""} {Error "Missing head sizes after 'head'"}
        if {[llength $head] != 2} \
          {Error "Specification for head should be 'head {ratio width}'"}
        set head [concat $head [lindex [lindex $data 3] 2]]
        set data [lreplace $data 3 3 $head]
      }
      relative {
        set head [lindex $data 3]
        if {[llength $head] == 0} {set head {{} {} {}}}
        if {[llength $head] == 2} {set head "$head {}"}
        set data [lreplace $data 3 3 [lreplace $head 2 2 1]]
      }
      absolute {
        set head [lindex $data 3]
        if {[llength $head] == 0} {set head {{} {} {}}}
        if {[llength $head] == 2} {set head "$head {}"}
        set data [lreplace $data 3 3 [lreplace $head 2 2 0]]
      }
      vcolors {Error "Unknown attribute 'vcolors'"}
      default {return [basicPolyhedron VFdata $actions]}
    }
    return [lrange $actions [incr i] end]
  }

  Method Recolor {} {
    Vars F C
    upvar _X _X; upvar _Y _Y
    Self Color Init
    set d [Self getDimension]
    set C {}
    foreach arrow $F {
      if {[llength [lindex $arrow 0]] == 3} {
        lappend C $tail
      } else {
        set color [lindex $arrow 2]
        set arrow [lindex $arrow 0]
        if {$color == ""} {
          set X [lindex $arrow 0]; set _Y [lindex $arrow 1]
          for {set i 0} {$i < $d} {incr i} {set _X($i) [lindex $X $i]}
          set color [$ColorFN]
        }
        lappend C $color
        set tail $color
      }
    }
    set C [Self Color Normalize $C]
  }

  Method Create {name {data ""}} {
    set name [Parent Create $name $data]
    if {$data == ""} {$name Appearance set shading constant}
    return $name
  }

  Var {hlength .15} {hwidth .02} {htype s} {hrelative 1}
  Method <ArrowHead> {args} {
    global errorCode errorInfo
    if [set code [catch [list _bind(Rest) {{ratio .15} {width .02}} \
        {{solid ""} {outline ""} {relative ""} {absolute ""}} $args \
        [Self method <ArrowHead>]] err]] \
	{return -code $code -errorcode $errorCode -errorinfo $errorInfo $err}
    if {$outline != ""} {set [var htype] "o"} else {set [var htype] "s"}
    if {$absolute != ""} {set [var hrelative] 0} else {set [var hrelative] 1}
    set [var hlength] [uplevel [list _expr(Math) $ratio]]
    set [var hwidth] [uplevel [list _expr(Math) $width]]
  }
  ClassVar {ArrowHead-template {.15 .02 -solid -relative}}

  Var {scale 1}
  Method <ArrowScale> {scale} {set [var scale] $scale}
  ClassVar {ArrowScale-template {1}}

  Var {maxlen 0} {keep 0}
  Method <ArrowMaxLen> {args} {
    global errorCode errorInfo
    if [set code [catch [list _bind(Rest) {{maxlen 0}} {{keep 0}} $args \
      [Self method <ArrowMaxLen>]] err]] \
      {return -code $code -errorcode $errorCode -errorinfo $errorInfo $err}
    set [var maxlen] $maxlen
    set [var keep] $keep
  }
  ClassVar {ArrowMaxLen-template {(length) -keep}}

  Method ScriptBegin {} {
    Vars hlength hwidth htype hrelative scale maxlen keep colorfn
    Parent ScriptBegin
    set hlength .15
    set hwidth .02
    set htype s
    set hrelative 1
    set scale 1
    set maxlen ""
    set keep 0
    unset colorfn(Normal)
  }
}
