# Meta description Commands to interact with the user in various
# Meta description simple ways, for a terminal.
# Meta subject {command line} tty interaction terminal
# Meta require {Tcl 8.5-}
# Meta require debug
# Meta require debug::caller
# Meta require cmdr::color
# Meta require cmdr::say
# Meta require try
# Meta require linenoise
# Meta require struct::matrix
# Meta require textutil::adjust
# @@ Meta End

# # ## ### ##### ######## ############# #####################
## Requisites

package require Tcl 8.5
package require cmdr::color
package require cmdr::say
package require debug
package require debug::caller
package require linenoise
package require try
package require struct::matrix
package require textutil::adjust

namespace eval ::cmdr {
    namespace export ask
}
namespace eval ::cmdr::ask {
    namespace export string string/extended string* yn choose menu
    namespace ensemble create

    namespace import ::cmdr::color
    namespace import ::cmdr::say
}

# # ## ### ##### ######## ############# #####################

debug define cmdr/ask
debug level  cmdr/ask
debug prefix cmdr/ask {[debug caller] | }

	    if {$e eq "aborted"} {
		error Interrupted error SIGTERM
	    }
	    return {*}${o} $e
	}
	if {$response eq {}} { set response $default }
	if {[::string is bool $response]} break

	# Show error for a second, then move back to the interaction
	# line and retry (which overwrites the old string).
	say add [color bad [Wrap "You must choose \"yes\" or \"no\""]]
	after 1000
	say rewind
	say up

	# Clear header to prevent redisplay, this part is fixed above
	# the actual input line.
	set header {}
    }

    return $response
}

proc ::cmdr::ask::choose {query choices {default {}}} {
    debug.cmdr/ask {}

	    }
	    return {*}${o} $e
	}
	if {($response eq {}) && $hasdefault} {
	    set response $default
	}
	if {$response in $choices} break

	# Show error for a second, then move back to the interaction
	# line and retry (which overwrites the old string).
	say add [color bad [Wrap "You must choose one of $lc"]]
	after 1000
	say rewind
	say up

	# Clear header to prevent redisplay, this part is fixed above
	# the actual input line.
	set header {}
    }

    return $response
}

proc ::cmdr::ask::menu {header prompt choices {default {}}} {
    debug.cmdr/ask {}

	incr n
    }
    set Mstr [M format 2string]
    M destroy

    # Format the prompt
    lassign [Fit $prompt 5] pheader prompt

    if {$header ne {}} { say line $header }
    say line $Mstr

    # Interaction loop
    while {1} {



	try {
	    set response \
		[Interact $pheader $prompt \
		     -complete [namespace code [list Complete $fullchoices 0]]]
	} on error {e o} {
	    if {$e eq "aborted"} {
		error Interrupted error SIGTERM

	if {[::string is int $response]} {
	    # Inserting a dummy to handle indexing from 1...
	    set response [lindex [linsert $choices 0 {}] $response]
	    if {$response in $choices} break
	}

	# Show error for a second, then move back to the interaction
	# line and retry (which overwrites the old string).
	say add [color bad [Wrap "You must choose one of the above"]]
	after 1000
	say rewind
	say up

	# Clear header to prevent redisplay, this part is fixed above
	# the actual input line.
	set pheader {}
    }

    return $response
}

# # ## ### ##### ######## ############# #####################

	lappend candidates $c
    }
    return $candidates
}

proc ::cmdr::ask::Interact {header prompt args} {
    debug.cmdr/ask {}
    if {$header ne {}} { say line $header }
    return [linenoise prompt {*}$args -prompt $prompt]
}

proc ::cmdr::ask::Wrap {text {down 0}} {
    debug.cmdr/ask {}
    global env
    if {[info exists env(CMDR_NO_WRAP)]} {

#!/usr/bin/env tclsh
# -*- tcl -*-

#lappend auto_path [file dirname [file dirname [file normalize [info script]]]]
#puts "= [join $auto_path "\n= "]"
source  [file dirname [file dirname [file normalize [info script]]]]/say.tcl

source [lindex $argv 0]
exit

#!/usr/bin/env tclsh
# -*- tcl -*-
package require Tcl 8.5
package require cmdr::say

puts |[join [cmdr say barber-phases 16 {**  }] |\n|]|

exit

#!/usr/bin/env tclsh
# -*- tcl -*-
package require Tcl 8.5
package require cmdr::say

# infinite barberpole
set B [cmdr say barberpole -width 30]
while {1} {
    after 100
    cmdr say rewind
    $B step
}

exit

#!/usr/bin/env tclsh
# -*- tcl -*-
package require Tcl 8.5
package require cmdr::say

# infinite barberpole with a prefix
set B [cmdr say barberpole -width 30]
cmdr say add "download ... "
cmdr say lock-prefix
while {1} {
    #
    # fake download, unknown size, sync ... actual use:
    # - fcopy callback,
    # - http progress-callback
    # - tcllib transfer callback
    after 100
    #
    cmdr say rewind
    $B step
}

exit

#!/usr/bin/env tclsh
# -*- tcl -*-
package require Tcl 8.5
package require cmdr::say

# progress counter.
set B [cmdr say progress-counter 100]
set i 0
cmdr say add "upload ... "
cmdr say lock-prefix
while {$i < 100} {
    #
    # fake upload, sync ... actual use:
    # - fcopy callback,
    # - http progress-callback
    # - tcllib transfer callback
    after 100
    #
    cmdr say rewind
    incr i
    $B step $i
}

exit

#!/usr/bin/env tclsh
# -*- tcl -*-
package require Tcl 8.5
package require cmdr::say

# scanner
set B [cmdr say animate -phases {
    {[***      ]}
    {[** *     ]}
    {[ ** *    ]}
    {[  ** *   ]}
    {[   ** *  ]}
    {[    ** * ]}
    {[     ** *]}
    {[      ***]}
    {[     * **]}
    {[    * ** ]}
    {[   * **  ]}
    {[  * **   ]}
    {[ * **    ]}
    {[* **     ]}
}]
while {1} {
    after 100
    cmdr say rewind
    $B step

    # NOTE: putting the rewind after the step means that we will
    # see the animation output only for a split second and the
    # erased/empty line for the 100 milli delay => the terminal
    # will look empty, with nothing happening.
}

exit

#!/usr/bin/env tclsh
# -*- tcl -*-
package require Tcl 8.5
package require cmdr::say

# infinite slider - semi-barberpole
set B [cmdr say animate -phases {
    {[         ]}
    {[*        ]}
    {[**       ]}
    {[***      ]}
    {[* **     ]}
    {[ * **    ]}
    {[  * **   ]}
    {[   * **  ]}
    {[    * ** ]}
    {[     * **]}
    {[      * *]}
    {[       * ]}
    {[        *]}
}]
while {1} {
    after 100
    cmdr say rewind
    $B step
}

exit

#!/usr/bin/env tclsh
# -*- tcl -*-
package require Tcl 8.5
package require cmdr::say

# larson scanner
set B [cmdr say animate -phases [cmdr say larson-phases 9 ***]]
while {1} {
    after 100
    cmdr say rewind
    $B step

    # NOTE: putting the rewind after the step means that we will
    # see the animation output only for a split second and the
    # erased/empty line for the 100 milli delay => the terminal
    # will look empty, with nothing happening.
}

exit

#!/usr/bin/env tclsh
# -*- tcl -*-
package require Tcl 8.5
package require cmdr::say

puts |[join [cmdr say larson-phases 23 ***] |\n|]|

exit

#!/usr/bin/env tclsh
# -*- tcl -*-
package require Tcl 8.5
package require cmdr::say

cmdr say operation {Upload ... } {
    after 5000 {set ::done ok}
    vwait ::done
} -play {cmdr say barberpole -width -11}

exit

#!/usr/bin/env tclsh
# -*- tcl -*-
package require Tcl 8.5
package require cmdr::say

cmdr say operation {Upload } {
    after 5000 {set ::done ok}
    vwait ::done
} -play {cmdr say ping -width 31 -wrap 1}

exit

#!/usr/bin/env tclsh
# -*- tcl -*-
package require Tcl 8.5
package require cmdr::say

cmdr say operation {Upload } {
    after 5000 {set ::done ok}
    vwait ::done
} -every 50 -play {cmdr say pulse -width 7}

exit

#!/usr/bin/env tclsh
# -*- tcl -*-
package require Tcl 8.5
package require cmdr::say

cmdr say operation {Upload } {
    after 5000 {set ::done ok}
    vwait ::done
} -every 50 -play {cmdr say turn}

exit

#!/usr/bin/env tclsh
# -*- tcl -*-
package require Tcl 8.5
package require cmdr::say

# percent progress counter
set B [cmdr say percent -max 10000 -digits 2]
set i 0
cmdr say add "upload ... "
cmdr say lock-prefix
while {$i < 10000} {
    #
    # fake upload, sync ... actual use:
    # - fcopy callback,
    # - http progress-callback
    # - tcllib transfer callback
    after 10
    #
    cmdr say rewind
    incr i
    $B step $i
}

exit

#!/usr/bin/env tclsh
# -*- tcl -*-
package require Tcl 8.5
package require cmdr::say

# ping bar
#set B [cmdr say ping -width 17]
#set B [cmdr say ping -width 17 -wrap 1]
set B [cmdr say ping -width 41 -wrap 1 -head {} -map {	    100000 @
	    10000  \#
	    1000   %
	    100    |
	    10     *
    1      {}
}]
#set B [cmdr say ping -width -8 -wrap 1]
#set B [cmdr say ping -width -8]
#set B [cmdr say ping -width Inf]
cmdr say add "upload "
cmdr say lock-prefix
while {1} {
    #
    # fake upload, sync ... actual use:
    # - fcopy callback,
    # - http progress-callback
    # - tcllib transfer callback
    after 10
    #
    cmdr say rewind
    $B step
}

exit

#!/usr/bin/env tclsh
# -*- tcl -*-
package require Tcl 8.5
package require cmdr::say

# percent progress bar
set B [cmdr say progress -max 1000 -width 50]
set C [cmdr say percent  -max 1000]
set i 0
cmdr say add "upload ... "
cmdr say lock-prefix
while {$i < 1000} {
    #
    # fake upload, sync ... actual use:
    # - fcopy callback,
    # - http progress-callback
    # - tcllib transfer callback
    after 10
    #
    cmdr say rewind
    incr i
    cmdr say add \[
    $B step $i
    cmdr say add \]

    cmdr say add { }
    $C step $i
}
#after 10
#cmdr say rewind
cmdr say line { OK}

exit

#!/usr/bin/env tclsh
# -*- tcl -*-
package require Tcl 8.5
package require cmdr::say

# percent progress bar, full width
set C [cmdr say percent -max 1000]

set  n [string length "upload ... \[\] "]
incr n [$C width]

set B [cmdr say progress -max 1000 -width -$n]
set i 0
cmdr say add "upload ... "
cmdr say lock-prefix
while {$i < 1000} {
    #
    # fake upload, sync ... actual use:
    # - fcopy callback,
    # - http progress-callback
    # - tcllib transfer callback
    after 10
    #
    cmdr say rewind
    incr i
    $C step $i
    cmdr say add { }

    cmdr say add \[
    $B step $i
    cmdr say add \]
}
after 1000
cmdr say rewind
cmdr say line { OK}

exit

#!/usr/bin/env tclsh
# -*- tcl -*-
package require Tcl 8.5
package require cmdr::say

puts |[join [cmdr say progress-phases 6 * ^] |\n|]|

exit

#!/usr/bin/env tclsh
# -*- tcl -*-
package require Tcl 8.5
package require cmdr::say

# infinite pulse - semi-barberpole
set B [cmdr say animate \
	   -phases [cmdr say pulse-phases 3 [cmdr color {bg-blue white} *]]]
while {1} {
    after 100
    cmdr say rewind
    $B step
}

exit

#!/usr/bin/env tclsh
# -*- tcl -*-
package require Tcl 8.5
package require cmdr::say

puts |[join [cmdr say pulse-phases 6 *] |\n|]|

exit

#!/usr/bin/env tclsh
# -*- tcl -*-
package require Tcl 8.5
package require cmdr::say

puts |[join [cmdr say pulse-phases 3 [cmdr color red .]] |\n|]|

exit

#!/usr/bin/env tclsh
# -*- tcl -*-
package require Tcl 8.5
package require cmdr::say

# infinite slider - semi-barberpole
set B [cmdr say animate -phases [cmdr say slider-phases 9 ***]]
while {1} {
    after 100
    cmdr say rewind
    $B step
}

exit

#!/usr/bin/env tclsh
# -*- tcl -*-
package require Tcl 8.5
package require cmdr::say

puts |[join [cmdr say slider-phases 9 ***] |\n|]|

exit

#!/usr/bin/env tclsh
# -*- tcl -*-
package require Tcl 8.5
package require cmdr::say

# turn 
set B [cmdr say animate -phases [cmdr say turn-phases]]
while {1} {
    after 100
    cmdr say rewind
    cmdr say add (
    $B step
    cmdr say add )

    # NOTE: putting the rewind after the step means that we will
    # see the animation output only for a split second and the
    # erased/empty line for the 100 milli delay => the terminal
    # will look empty, with nothing happening.
}

exit

#!/usr/bin/env tclsh
# -*- tcl -*-
package require Tcl 8.5
package require cmdr::say

puts ([join [cmdr say turn-phases] )\n(])

exit

## -*- tcl -*-
# # ## ### ##### ######## ############# #####################
## CMDR - Convenience commands for terminal manipulation and output

# @@ Meta Begin
# Package cmdr::say 0
# Meta author   {Andreas Kupries}
# Meta location https://core.tcl.tk/akupries/cmdr
# Meta platform tcl
# Meta summary     Terminal manipulation and output.
# Meta description Commands to generate terminal output, to control
# Meta description the terminal, and print text
# Meta subject {command line} tty interaction terminal
# Meta require {Tcl 8.5-}
# Meta require debug
# Meta require debug::caller
# Meta require cmdr::color
# Meta require linenoise
# Meta require TclOO
# @@ Meta End

# # ## ### ##### ######## ############# #####################
##

# Notes on things to work on ...

# - "operation" is possibly mis-named. Its main topic looks to be
#   about animation which is green-threaded around its code-block.
#
# - Animation, or in general, "animated feedback" needs flags and
#   acessors to disable it, for example when stdout is not a
#   tty. Similar to how the color commands become no-ops in that case.
#
#   Because usually we do not wish to clutter a log file with the
#   mixture of strings and terminal control sequences used to implement
#   the animations.
#
# - Strongly consider moving "operation" and the various animation
#   classes into a separate package operating on top of this one,
#   i.e. "cmdr::say". This would have the flag control as well.
#
# - Regarding base animation classes have to implement compositing
#   classes (wrapper for fixed header/trailer strings around an
#   animation, sequence of animations (must have matching 'step'
#   signature) - Interesting case for sequences: How much can we
#   automate (derive) the individual -width specifications from an
#   overall setting and knowledge of fixed sizes ?
#
# - Animation implementation base class => configure|cget API
#
# - Two common use-cases for the animations:
#
#   (a) Timer-driven animation, usually for an operation not
#       generating (usable) feedback.
#
#   (b) Progress-driven animation, usually for an operation generating
#       proper feedback we can use to drive it.

# # ## ### ##### ######## ############# #####################
## Requisites

package require Tcl 8.5
package require cmdr::color
package require debug
package require debug::caller
package require linenoise
package require TclOO
package require try

namespace eval ::cmdr {
    namespace export say
}
namespace eval ::cmdr::say {
    namespace export \
	up down forw back \
	erase-screen erase-up erase-down \
	erase-line erase-back erase-forw \
	goto home line add trouble rewind lock-prefix clear-prefix \
	next next* animate barberpole percent progress-counter progress \
	ping pulse turn larson slider operation header banner \
	\
	auto-width barber-phases progress-phases larson-phases \
	slider-phases pulse-phases turn-phases \
	\
	to

    namespace ensemble create
    namespace import ::cmdr::color

    # State for "add", "lock-prefix", "clear-prefix", and "rewind"
    variable prefix {}
    variable pre    {}

    # Channel to write to. Default is stdout. Mainly to allow
    # redirection during testing.
    variable to
}

# # ## ### ##### ######## ############# #####################

debug define cmdr/say
debug level  cmdr/say
debug prefix cmdr/say {[debug caller] | }

# # ## ### ##### ######## ############# #####################
## output redirection

proc ::cmdr::say::to {{chan {}}} {
    debug.cmdr/say {}
    variable to
    if {[llength [info level 0]] == 1} {
	return $chan
    }
    set to $chan
    return
}

# # ## ### ##### ######## ############# #####################
## cursor movement

proc ::cmdr::say::up {{n 1}} {
    debug.cmdr/say {}
    puts -nonewline stdout \033\[${n}A
    flush           stdout
    return
}

proc ::cmdr::say::down {{n 1}} {
    debug.cmdr/say {}
    puts -nonewline stdout \033\[${n}B
    flush           stdout
    return
}

proc ::cmdr::say::forw {{n 1}} {
    debug.cmdr/say {}
    puts -nonewline stdout \033\[${n}C
    flush           stdout
    return
}

proc ::cmdr::say::back {{n 1}} {
    debug.cmdr/say {}
    puts -nonewline stdout \033\[${n}D
    flush           stdout
    return
}

# # ## ### ##### ######## ############# #####################
## (partial) screen erasure

proc ::cmdr::say::erase-screen {{suffix {}}} {
    debug.cmdr/say {}
    puts -nonewline stdout \033\[2J$suffix
    flush           stdout
    return
}

proc ::cmdr::say::erase-up {{suffix {}}} {
    debug.cmdr/say {}
    puts -nonewline stdout \033\[1J$suffix
    flush           stdout
    return
}

proc ::cmdr::say::erase-down {{suffix {}}} {
    debug.cmdr/say {}
    puts -nonewline stdout \033\[0J$suffix
    flush           stdout
    return
}

# # ## ### ##### ######## ############# #####################
## (partial) line erasure

proc ::cmdr::say::erase-line {{suffix {}}} {
    debug.cmdr/say {}
    puts -nonewline stdout \033\[2K$suffix
    flush           stdout
    return
}

proc ::cmdr::say::erase-back {{suffix {}}} {
    debug.cmdr/say {}
    puts -nonewline stdout \033\[1K$suffix
    flush           stdout
    return
}

proc ::cmdr::say::erase-forw {{suffix {}}} {
    debug.cmdr/say {}
    puts -nonewline stdout \033\[0K$suffix
    flush           stdout
    return
}

# # ## ### ##### ######## ############# #####################
## absolute cursor movement

proc ::cmdr::say::goto {x y} {
    debug.cmdr/say {}
    puts -nonewline stdout \033\[${y};${x}f
    flush           stdout
    return
}

proc ::cmdr::say::home {} {
    debug.cmdr/say {}
    puts -nonewline stdout \033\[H
    flush           stdout
    return
}

# # ## ### ##### ######## ############# #####################
## bottom level line output and animation control

proc ::cmdr::say::add {text} {
    debug.cmdr/say {}
    variable pre
    append   pre $text
    puts -nonewline stdout $text
    flush           stdout
    return
}

proc ::cmdr::say::line {text} {
    debug.cmdr/say {}
    variable pre    {}
    variable prefix {}
    puts  stdout $text
    flush stdout
    return
}

proc ::cmdr::say::trouble {text} {
    debug.cmdr/say {}
    puts  stderr $text
    flush stderr
    return
}

proc ::cmdr::say::rewind {} {
    debug.cmdr/say {}
    variable prefix
    erase-line \r$prefix
    return
}

proc ::cmdr::say::lock-prefix {} {
    debug.cmdr/say {}
    variable pre
    variable prefix $pre
    return
}

proc ::cmdr::say::clear-prefix {} {
    debug.cmdr/say {}
    variable prefix {}
    return
}

proc ::cmdr::say::next {} {
    debug.cmdr/say {}
    clear-prefix
    puts  stdout ""
    flush stdout
    return
}

proc ::cmdr::say::next* {} {
    debug.cmdr/say {}
    puts  stdout ""
    flush stdout
    return
}

# # ## ### ##### ######## ############# #####################

proc ::cmdr::say::header {text {filler -}} {
    debug.cmdr/say {}
    line \n${text}\n[string repeat $filler [string length $text]]
    return
}

proc ::cmdr::say::banner {text} {
    debug.cmdr/say {}
    line \n$text
    return
}

proc ::cmdr::say::operation {lead script args} {
    debug.cmdr/say {}

    set cmd     {}  ;# -play
    set delay   100 ;# -every
    set trailer OK  ;# -trailer, -no-trailer

    while {1} {
	set o [lindex $args 0]
	switch -glob -- $o {
	    -every { ;# int number argument
		set delay [lindex $args 1]
		set args  [lrange $args 2 end]
	    }
	    -play { ;# cmd prefix argument
		set cmd  [lindex $args 1]
		set args [lrange $args 2 end]
	    }
	    -no-trailer { ;# no argument
		set trailer {}
		set args    [lrange $args 1 end]
	    }
	    -trailer { ;# string argument
		set trailer [lindex $args 1]
		set args    [lrange $args 2 end]
	    }
	    -* {
		return -code error \
		    -errorcode {CMD SAY BAD-OPTION} \
		    "Unknown option $o, expected -every, -play, or -(no-)trailer"
	    }
	    default break
	}
    }

    add $lead
    lock-prefix

    if {[llength $cmd]} {
	set animation [uplevel 1 $cmd]
	$animation run $delay
    }

    try {
	uplevel 1 $script
    } {*}$args on error {e o} {
	# General error => close line, and pass.
	line ""
	return {*}$o $e
    } on ok {e o} {
	rewind ; # remove animation output, leave only the lead
	if {$trailer ne {}} {
	    line [color good $trailer]
	}
    } finally {
	# Stop ongoing animation, if any
	if {[llength $cmd]} {
	    $animation done
	}
    }
    return $e
}

# # ## ### ##### ######## ############# #####################
## Animation helper class (timer driven auto-step).

oo::class create ::cmdr::say::Auto {
    variable mytimer

    method run {delay} {
	debug.cmdr/say {}
	my stop ;# Kill a running timer, this allows us to call sequences of runs without worrying about the system state.

	cmdr say rewind
	my step

	set mytimer [after $delay [info level 0]]
	return
    }

    method stop {} {
	debug.cmdr/say {}
	catch {
	    after cancel $mytimer
	}
	set mytimer {}
	return
    }

    destructor {
	debug.cmdr/say {}
	my stop
    }
}

# # ## ### ##### ######## ############# #####################
## general animation command and class

proc ::cmdr::say::animate {args} {
    debug.cmdr/say {}
    array set config $args
    Require config -phases
    return [animate::Im new -phases [Fill $config(-phases)]]
}

oo::class create ::cmdr::say::animate::Im {
    superclass ::cmdr::say::Auto
    variable myphases myphase mywidth

    constructor {args} {
	debug.cmdr/say {}
	my configure {*}$args
	return
    }

    method configure {args} {
	array set config $args
	::cmdr::say::Require config -phases

	set myphases $config(-phases)
	set myphase  0
	set mywidth  [string length [lindex $myphases 0]]
	return
    }

    method width {} {
	debug.cmdr/say {}
	return $mywidth
    }

    method step {} {
	debug.cmdr/say {}
	cmdr say add [lindex $myphases $myphase]
	incr myphase
	if {$myphase == [llength $myphases]} { set myphase 0 }
	return
    }

    method goto {phase} {
	debug.cmdr/say {}
	set myphase $phase
	cmdr say add [lindex $myphases $myphase]
	return
    }

    method done {} {
	debug.cmdr/say {}
	my destroy
    }
}

# # ## ### ##### ######## ############# #####################
## barberpole animation

proc ::cmdr::say::barberpole {args} {
    debug.cmdr/say {}

    array set config {
	-width   {}
	-pattern {**  }
    }
    array set config $args

    set phases [barber-phases \
		    [auto-width $config(-width)] \
		    $config(-pattern)]

    # Run the animation via the general class.
    return [animate::Im new -phases $phases]
}

# # ## ### ##### ######## ############# #####################
## pulse animation

proc ::cmdr::say::pulse {args} {
    debug.cmdr/say {}

    array set config {
	-width   {}
	-stem    .
    }
    array set config $args

    set phases [pulse-phases \
		    [auto-width $config(-width)] \
		    $config(-stem)]

    # Run the animation via the general class.
    return [animate::Im new -phases $phases]
}

# # ## ### ##### ######## ############# #####################
## turn animation

proc ::cmdr::say::turn {} {
    debug.cmdr/say {}
    set phases [turn-phases]
    # Run the animation via the general class.
    return [animate::Im new -phases $phases]
}

# # ## ### ##### ######## ############# #####################
## slider animation

proc ::cmdr::say::slider {args} {
    debug.cmdr/say {}

    array set config {
	-width   {}
	-pattern ***
    }
    array set config $args

    set phases [slider-phases \
		    [auto-width $config(-width)] \
		    $config(-pattern)]

    # Run the animation via the general class.
    return [animate::Im new -phases $phases]
}

# # ## ### ##### ######## ############# #####################
## larson scanner animation

proc ::cmdr::say::larson {args} {
    debug.cmdr/say {}

    array set config {
	-width   {}
	-pattern ***
    }
    array set config $args

    set phases [larson-phases \
		    [auto-width $config(-width)] \
		    $config(-pattern)]

    # Run the animation via the general class.
    return [animate::Im new -phases $phases]
}

# # ## ### ##### ######## ############# #####################
## progress counter, n of max.

proc ::cmdr::say::progress-counter {max} {
    debug.cmdr/say {}
    return [progress-counter::Im new $max]
}

oo::class create ::cmdr::say::progress-counter::Im {
    superclass ::cmdr::say::Auto
    variable mywidth myformat mymax

    constructor {max} {
	debug.cmdr/say {}
	set n [string length $max]
	set mymax    $max
	set mywidth  [expr {1+2*$n}]
	set myformat %${n}d/%d
	return
    }

    method width {} {
	debug.cmdr/say {}
	return $mywidth
    }

    method step {at} {
	debug.cmdr/say {}
	cmdr say add [format $myformat $at $mymax]
	return
    }

    method done {} {
	debug.cmdr/say {}
	my destroy
    }
}

# # ## ### ##### ######## ############# #####################
## progress counter, in percent.

proc ::cmdr::say::percent {args} {
    debug.cmdr/say {}

    array set config {
	-max    100
	-digits 2
    }
    array set config $args

    return [percent::Im new $config(-max) $config(-digits)]
}

oo::class create ::cmdr::say::percent::Im {
    superclass ::cmdr::say::Auto
    variable mywidth myformat mymax

    constructor {max digits} {
	debug.cmdr/say {}
	set mymax $max

	set mywidth 3
	if {$digits} {
	    incr mywidth ;# .
	    incr mywidth $digits
	}
	set myformat %${mywidth}.${digits}f
	return
    }

    method width {} {
	debug.cmdr/say {}
	return $mywidth
    }

    method step {at} {
	debug.cmdr/say {}
	set percent [expr {100*double($at)/double($mymax)}]
	cmdr say add [format $myformat $percent]%
	return
    }

    method done {} {
	debug.cmdr/say {}
	my destroy
    }
}

# # ## ### ##### ######## ############# #####################
## progress-bar

proc ::cmdr::say::progress {args} {
    debug.cmdr/say {}

    array set config {
	-max    100
	-width  {}
	-stem   =
	-head   >
    }
    array set config $args

    set phases [progress-phases \
		    [auto-width $config(-width)] \
		    $config(-stem) \
		    $config(-head)]

    return [progress::Im new $config(-max) $phases]
}

oo::class create ::cmdr::say::progress::Im {
    variable mymax myphases

    constructor {max phases} {
	debug.cmdr/say {}
	# Inner object, general animation, container for our phases.
	cmdr::say::animate::Im create A -phases $phases
	set mymax    $max
	set myphases [llength $phases]
	return
    }

    forward width \
	A width

    method step {at} {
	debug.cmdr/say {}
	set phase [expr {int($myphases * (double($at)/double($mymax)))}]
	if {$phase >= $myphases} { set phase end }
	A goto $phase
	return
    }

    method done {} {
	debug.cmdr/say {}
	my destroy
    }
}


# # ## ### ##### ######## ############# #####################
## ping

proc ::cmdr::say::ping {args} {
    debug.cmdr/say {}

    # Options
    # -head  string - Show in front of the ping characters.
    # -map   dict   - Map moduli to characters, when reached.
    #                 Order relevant, largest moduli first.
    #                 End with modulus 1, always matching!
    #                 (System will internally add such to close the map).
    # -width int    - Amount of space to use for the moving ping+head
    # -wrap  bool   - Wrapping keeps the moving part within the current line.
    #                 Without wrap a wrap goes to the next line using next*.

    array set config {
	-wrap 0
	-head &
	-map {
	    100000 @
	    10000  \#
	    1000   %
	    100    |
	    10     *
	    1      .
	}
	-width {}
    }
    array set config $args

    return [ping::Im new \
		$config(-wrap) \
		$config(-head) \
		$config(-map) \
		[auto-width $config(-width)]]
}

oo::class create ::cmdr::say::ping::Im {
    superclass ::cmdr::say::Auto
    variable mywrap myhead mymap mywidth myphase mybuffer myewidth mytrail

    constructor {wrap head map width} {
	debug.cmdr/say {}

	# close map, if user forgot. No-op if user closed it.
	lappend map 1 _ ;# default char configurable ?

	set mywrap   $wrap
	set myhead   $head
	set mymap    $map
	set mywidth  $width
	set myewidth [expr {$mywidth - [string length $head]}] ;# effective width.
	set myphase  0
	set mybuffer ""
	if {$mywrap} {
	    set mytrail [string repeat { } $myewidth]
	} else {
	    set mytrail {}
	}
	return
    }

    method width {} { return $mywidth }

    method step {} {
	debug.cmdr/say {}

	set ch [my Next]

	# Create a buffer to print, from the previous state.
	# First attempt. Without a head leading the pings.

	append  mybuffer $ch
	set str $mybuffer

	if {$mywrap} {
	    set mytrail [string range $mytrail 1 end]
	}

	if {[string length $str] < $myewidth} {
	    # Still fits. Simply print.
	    cmdr say add $str$myhead$mytrail
	} else {
	    # Too long. Split into a fitting piece and overshot.
	    set fit  [string range $str 0          ${myewidth}-1]
	    set over [string range $str ${myewidth} end]

	    # Print the fitting piece first to complete the line,
	    # then move to the next line and print the overshot.
	    cmdr say add $fit

	    if {!$mywrap} {
		cmdr say next*      ;# no-wrap: next line, keep current prefix.
	    } else {
		cmdr say rewind     ;# wrap:    rewind/clear line and continue
	    }
	    cmdr say add $over$myhead$mytrail

	    # Set state for next call.
	    set mybuffer $over
	    if {$mywrap} {
		set mytrail $fit
	    }
	}
	return
    }

    method done {} {
	debug.cmdr/say {}
	my destroy
    }

    method Next {} {
	incr myphase
	foreach {mod char} $mymap {
	    if {($myphase % $mod) != 0} continue
	    return $char
	}
	return -code error -errorcode ... ""
    }
}

# # ## ### ##### ######## ############# #####################

proc ::cmdr::say::auto-width {width} {
    debug.cmdr/say {}

    if {$width eq {}} {
	# Nothing defined, adapt to terminal width
	set width [linenoise columns]
    } elseif {$width < 0} {
	# Adapt to terminal width, with some space reserved.
	set width [expr {[linenoise columns] + $width}]
    }
    return $width
}

# # ## ### ##### ######## ############# #####################

proc ::cmdr::say::barber-phases {width pattern} {
    debug.cmdr/say {}

    # Repeat the base pattern as necessary to fill the requested
    # width. We use a count which gives us something which might be a
    # bit over, so after replication the resulting string is cut down
    # to the exact size.
    set n    [expr {int(0.5+ceil($width / double([string length $pattern])))}]
    set base [string range [string repeat $pattern $n] 0 ${width}-1]

    # Example for standard pattern '**  ', widths 16, and 17.
    # |**  **  **  **  |
    # | **  **  **  ** |
    # |  **  **  **  **|
    # |*  **  **  **  *|

    # |**  **  **  **  *| Note how the odd length yields one larger
    # |***  **  **  **  | band (***) in the pattern, which ripples
    # | ***  **  **  ** | across, and multiplies the number of phases
    # |  ***  **  **  **| before reaching the origin again.
    # |*  ***  **  **  *|
    # |**  ***  **  **  | Similar effects will be had for for any width
    # | **  ***  **  ** | which W != 0 mod (length pattern).
    # |  **  ***  **  **|
    # |*  **  ***  **  *|
    # |**  **  ***  **  |
    # | **  **  ***  ** |
    # |  **  **  ***  **|
    # |*  **  **  ***  *|
    # |**  **  **  ***  |
    # | **  **  **  *** |
    # |  **  **  **  ***|
    # |*  **  **  **  **|

    lappend phases $base
    # rotate the base through all configurations until we reach it again.
    set next $base
    while {1} {
	set next [string range $next 1 end][string index $next 0]
	if {$next eq $base} break
	lappend phases $next
    }

    return $phases
}

proc ::cmdr::say::progress-phases {width stem head} {
    debug.cmdr/say {}

    # compute phases.
    set h [string length $head]
    set phases {}
    for {set i 0} {$i < ($width - $h)} {incr i} {
	lappend phases [string repeat $stem $i]$head
	# >, =>, ==>, ...
    }

    return [Fill $phases]
}

proc ::cmdr::say::larson-phases {width pattern} {
    debug.cmdr/say {}

    set n [string length $pattern]
    if {$n > $width} {
	return [list $pattern]
    }

    set spaces [expr {$width - $n}]

    # round 1: slide right
    for {
	set pre  0
	set post $spaces
    } { $post > 0 } {
	incr pre
	incr post -1
    } {
	lappend phases [string repeat { } $pre]${pattern}[string repeat { } $post]
    }

    # round 2: slide left
    for {
	set pre  $spaces
	set post 0
    } { $pre > 0 } {
	incr pre  -1
	incr post
    } {
	lappend phases [string repeat { } $pre]${pattern}[string repeat { } $post]
    }

    return $phases
}

proc ::cmdr::say::slider-phases {width pattern} {
    debug.cmdr/say {}

    set n [string length $pattern]
    if {$n > $width} {
	return [list $pattern]
    }

    # round 1: slide pattern in.
    lappend phases {}
    for {set k 0} {$k < $n} {incr k} {
	lappend phases [string range $pattern end-$k end]
    }

    # round 2: slide pattern right.
    set spaces [expr {$width - $n}]
    for {
	set pre  0
	set post $spaces
    } { $post > 0 } {
	incr pre
	incr post -1
    } {
	lappend phases [string repeat { } $pre]${pattern}[string repeat { } $post]
    }

    # round 3: slide pattern out.
    for {set k 0} {$k < $n} {incr k} {
	lappend phases [string repeat { } $pre][string range $pattern 0 end-$k]
	incr pre
    }

    return $phases
}

proc ::cmdr::say::pulse-phases {width stem} {
    debug.cmdr/say {}

    # compute phases.
    set phases {}
    for {set i 0} {$i <= $width} {incr i} {
	lappend phases [string repeat $stem $i]
    }
    return [Fill $phases]
}

proc ::cmdr::say::turn-phases {} {
    return [list | / - \\]
}

# # ## ### ##### ######## ############# #####################

proc ::cmdr::say::Require {cv option} {
    debug.cmdr/say {}
    upvar 1 $cv config
    if {[info exists config($option)]} return
    return -code error \
	-errorCode [list CMDR SAY OPTION MISSING $option] \
	"Missing required option \"$option\""
}

proc ::cmdr::say::Fill {phases} {
    # compute max length of phase strings
    set max [string length [lindex $phases 0]]
    foreach p [lrange $phases 1 end] {
	# Look for ANSI color control sequences and remove them. Avoid
	# counting their characters as such sequences as a whole
	# represent a state change, and are logically of zero/no
	# width.
	regsub -all "\033\\\[\[0-9;\]*m" $p {} p
	set n [string length $p]
	if {$n < $max} continue
	set max $n
    }

    # then pad all other strings which do not reach that length with
    # spaces at the end.
    set tmp {}
    foreach p $phases {
	# Look for ANSI color control sequences and discount
	# them. Avoid counting their characters as such sequences as a
	# whole represent a state change, and are logically of zero/no
	# width.
	regsub -all "\033\\\[\[0-9;\]*m" $p {} px
	set n [string length $px]
	if {$n < $max} {
	    append p [string repeat { } [expr {$max - $n}]]
	}
	lappend tmp $p
    }

    return $tmp
}

# # ## ### ##### ######## ############# #####################
## Ready
package provide cmdr::say 1

# -*- tcl -*- tcl.tk//DSL tcltest//EN//2.0
# # ## ### ##### ######## ############# #####################
## Testing the cmdr::say package.
#
# We are explicitly specifying the -width in all commands taking this
# option and do not use widths < 0. This is done to avoid all code
# paths actually requiring linenoise and interaction with the
# terminal.
#

kt check Tcl     8.5
kt check tcltest 2

kt require support TclOO
kt require support linenoise
kt require support debug
kt require support debug::caller

kt local   support cmdr::tty
kt local   support cmdr::color
kt local   testing cmdr::say

# # ## ### ##### ######## ############# #####################

proc setup {} {
    cmdr say to [open TEST w]
    return
}

proc see {} {
    close [cmdr say to]
    cmdr say to {}
    set chan [open TEST rb]
    set d    [read $chan]
    close $chan
    return $d
}

proc cleanup {} {
    cmdr say to {}
    return
}

# # ## ### ##### ######## ############# #####################

test cmdr-say-to-1.0 {to, wrong num args, too many} -body {
    cmdr say to C X
} -returnCodes error \
    -result {}

# # ## ### ##### ######## ############# #####################
## cursor movement

foreach {n move response1 response2} {
    0 up   \033\[1A \033\[2A
    1 down \033\[1B \033\[2B
    2 forw \033\[1C \033\[2C
    3 back \033\[1D \033\[2D
} {
    test cmdr-say-${move}-1.0 "$move, wrong num args, too many" -body {
	cmdr say $move N X
    } -returnCodes error \
	-result {}

    test cmdr-say-${move}-1.1 "$move, default" -body {
	cmdr say $move
	see
    } -setup setup -cleanup cleanup -result $response1

    test cmdr-say-${move}-1.2 "$move, explicit" -body {
	cmdr say $move 2
	see
    } -setup setup -cleanup cleanup -result $response2
}

# # ## ### ##### ######## ############# #####################
## erase screen

# # ## ### ##### ######## ############# #####################
## erase line

# # ## ### ##### ######## ############# #####################
## absolute moves

# # ## ### ##### ######## ############# #####################
## animations

# # ## ### ##### ######## ############# #####################
cleanupTests
return