cmdr
Check-in [faf4b58f8c]
Not logged in
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Draft work on an output package for basic terminal control, and animations (like progress-bars, barber-poles, counters, etc.)
Timelines: family | ancestors | descendants | both | say-more
Files: files | file ages | folders
SHA1: faf4b58f8c6c26b3fdfe6fd3e1e1f9967d920e5a
User & Date: andreask 2015-04-21 18:11:15
Context
2015-04-22
20:13
Worked the low-level output into the ask package as demo of use. Especially made the retry loops visually tighter (temp display of error on bad input, plus reuse of existing line for re-input, no redraw of fixed parts (headers, menu listings)). check-in: 4f4b8b9a82 user: andreask tags: say-more
2015-04-21
18:11
Draft work on an output package for basic terminal control, and animations (like progress-bars, barber-poles, counters, etc.) check-in: faf4b58f8c user: andreask tags: say-more
2015-04-17
23:24
history - Added missing docs. check-in: 860ef7cfb3 user: andreask tags: trunk
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Added say-ex.tcl.

            1  +
            2  +source color.tcl
            3  +source say.tcl
            4  +
            5  +#debug on cmdr/say
            6  +
            7  +if 0 {
            8  +    puts |[join [cmdr say larson-phases 23 ***] |\n|]|
            9  +    exit
           10  +}
           11  +
           12  +
           13  +if 0 {
           14  +    puts |[join [cmdr say pulse-phases 6 *] |\n|]|
           15  +    exit
           16  +}
           17  +
           18  +if 0 {
           19  +    puts |[join [cmdr say pulse-phases 3 [cmdr color red .]] |\n|]|
           20  +    exit
           21  +}
           22  +
           23  +if 0 {
           24  +    puts |[join [cmdr say progress-phases 6 * ^] |\n|]|
           25  +    exit
           26  +}
           27  +
           28  +if 0 {
           29  +    # larson scanner
           30  +    set B [cmdr say animate -phases [cmdr say larson-phases 9 ***]]
           31  +    while {1} {
           32  +	after 100
           33  +	cmdr say rewind
           34  +	$B step
           35  +
           36  +	# NOTE: putting the rewind after the step means that we will
           37  +	# see the animation output only for a split second and the
           38  +	# erased/empty line for the 100 milli delay => the terminal
           39  +	# will look empty, with nothing happening.
           40  +    }
           41  +}
           42  +
           43  +if 0 {
           44  +    # scanner
           45  +    set B [cmdr say animate -phases {
           46  +	{[***      ]}
           47  +	{[** *     ]}
           48  +	{[ ** *    ]}
           49  +	{[  ** *   ]}
           50  +	{[   ** *  ]}
           51  +	{[    ** * ]}
           52  +	{[     ** *]}
           53  +	{[      ***]}
           54  +	{[     * **]}
           55  +	{[    * ** ]}
           56  +	{[   * **  ]}
           57  +	{[  * **   ]}
           58  +	{[ * **    ]}
           59  +	{[* **     ]}
           60  +    }]
           61  +    while {1} {
           62  +	after 100
           63  +	cmdr say rewind
           64  +	$B step
           65  +
           66  +	# NOTE: putting the rewind after the step means that we will
           67  +	# see the animation output only for a split second and the
           68  +	# erased/empty line for the 100 milli delay => the terminal
           69  +	# will look empty, with nothing happening.
           70  +    }
           71  +}
           72  +
           73  +if 0 {
           74  +    # infinite slider - semi-barberpole
           75  +    set B [cmdr say animate -phases [cmdr say slider-phases 9 ***]]
           76  +    while {1} {
           77  +	after 100
           78  +	cmdr say rewind
           79  +	$B step
           80  +    }
           81  +}
           82  +
           83  +if 1 {
           84  +    # infinite slider - semi-barberpole
           85  +    set B [cmdr say animate -phases {
           86  +	{[         ]}
           87  +	{[*        ]}
           88  +	{[**       ]}
           89  +	{[***      ]}
           90  +	{[* **     ]}
           91  +	{[ * **    ]}
           92  +	{[  * **   ]}
           93  +	{[   * **  ]}
           94  +	{[    * ** ]}
           95  +	{[     * **]}
           96  +	{[      * *]}
           97  +	{[       * ]}
           98  +	{[        *]}
           99  +    }]
          100  +    while {1} {
          101  +	after 100
          102  +	cmdr say rewind
          103  +	$B step
          104  +    }
          105  +}
          106  +
          107  +if 0 {
          108  +    # infinite pulse - semi-barberpole
          109  +    set B [cmdr say animate \
          110  +	       -phases [cmdr say pulse-phases 3 [cmdr color {bg-blue white} *]]]
          111  +    while {1} {
          112  +	after 100
          113  +	cmdr say rewind
          114  +	$B step
          115  +    }
          116  +}
          117  +
          118  +if 0 {
          119  +    # infinite barberpole
          120  +    set B [cmdr say barberpole -width 30]
          121  +    while {1} {
          122  +	after 100
          123  +	cmdr say rewind
          124  +	$B step
          125  +    }
          126  +}
          127  +
          128  +if 0 {
          129  +    # infinite barberpole with a prefix
          130  +    set B [cmdr say barberpole -width 30]
          131  +    cmdr say add "download ... "
          132  +    cmdr say lock-prefix
          133  +    while {1} {
          134  +	#
          135  +	# fake download, unknown size, sync ... actual use:
          136  +	# - fcopy callback,
          137  +	# - http progress-callback
          138  +	# - tcllib transfer callback
          139  +	after 100
          140  +	#
          141  +	cmdr say rewind
          142  +	$B step
          143  +    }
          144  +}
          145  +
          146  +if 0 {
          147  +    # progress counter.
          148  +    set B [cmdr say progress-counter 100]
          149  +    set i 0
          150  +    cmdr say add "upload ... "
          151  +    cmdr say lock-prefix
          152  +    while {$i < 100} {
          153  +	#
          154  +	# fake upload, sync ... actual use:
          155  +	# - fcopy callback,
          156  +	# - http progress-callback
          157  +	# - tcllib transfer callback
          158  +	after 100
          159  +	#
          160  +	cmdr say rewind
          161  +	incr i
          162  +	$B step $i
          163  +    }
          164  +}
          165  +
          166  +if 0 {
          167  +    # percent progress counter
          168  +    set B [cmdr say percent -max 10000 -digits 2]
          169  +    set i 0
          170  +    cmdr say add "upload ... "
          171  +    cmdr say lock-prefix
          172  +    while {$i < 10000} {
          173  +	#
          174  +	# fake upload, sync ... actual use:
          175  +	# - fcopy callback,
          176  +	# - http progress-callback
          177  +	# - tcllib transfer callback
          178  +	after 10
          179  +	#
          180  +	cmdr say rewind
          181  +	incr i
          182  +	$B step $i
          183  +    }
          184  +}
          185  +
          186  +if 0 {
          187  +    # percent progress bar
          188  +    set B [cmdr say progress -max 1000 -width 50]
          189  +    set C [cmdr say percent  -max 1000]
          190  +    set i 0
          191  +    cmdr say add "upload ... "
          192  +    cmdr say lock-prefix
          193  +    while {$i < 1000} {
          194  +	#
          195  +	# fake upload, sync ... actual use:
          196  +	# - fcopy callback,
          197  +	# - http progress-callback
          198  +	# - tcllib transfer callback
          199  +	after 10
          200  +	#
          201  +	cmdr say rewind
          202  +	incr i
          203  +	cmdr say add \[
          204  +	$B step $i
          205  +	cmdr say add \]
          206  +
          207  +	cmdr say add { }
          208  +	$C step $i
          209  +    }
          210  +    #after 10
          211  +    #cmdr say rewind
          212  +    cmdr say line { OK}
          213  +}
          214  +
          215  +if 0 {
          216  +    # percent progress bar, full width
          217  +    set C [cmdr say percent -max 1000]
          218  +
          219  +    set  n [string length "upload ... \[\] "]
          220  +    incr n [$C width]
          221  +
          222  +    set B [cmdr say progress -max 1000 -width -$n]
          223  +    set i 0
          224  +    cmdr say add "upload ... "
          225  +    cmdr say lock-prefix
          226  +    while {$i < 1000} {
          227  +	#
          228  +	# fake upload, sync ... actual use:
          229  +	# - fcopy callback,
          230  +	# - http progress-callback
          231  +	# - tcllib transfer callback
          232  +	after 10
          233  +	#
          234  +	cmdr say rewind
          235  +	incr i
          236  +	$C step $i
          237  +	cmdr say add { }
          238  +
          239  +	cmdr say add \[
          240  +	$B step $i
          241  +	cmdr say add \]
          242  +    }
          243  +    after 1000
          244  +    cmdr say rewind
          245  +    cmdr say line { OK}
          246  +}

Added say.tcl.

            1  +## -*- tcl -*-
            2  +# # ## ### ##### ######## ############# #####################
            3  +## CMDR - Convenience commands for terminal manipulation and output
            4  +
            5  +# @@ Meta Begin
            6  +# Package cmdr::say 0
            7  +# Meta author   {Andreas Kupries}
            8  +# Meta location https://core.tcl.tk/akupries/cmdr
            9  +# Meta platform tcl
           10  +# Meta summary     Terminal manipulation and output.
           11  +# Meta description Commands to generate terminal output, to control
           12  +# Meta description the terminal, and print text
           13  +# Meta subject {command line} tty interaction terminal
           14  +# Meta require {Tcl 8.5-}
           15  +# Meta require debug
           16  +# Meta require debug::caller
           17  +# Meta require cmdr::color
           18  +# Meta require linenoise
           19  +# Meta require TclOO
           20  +# @@ Meta End
           21  +
           22  +# # ## ### ##### ######## ############# #####################
           23  +## Requisites
           24  +
           25  +package require Tcl 8.5
           26  +package require cmdr::color
           27  +package require debug
           28  +package require debug::caller
           29  +package require linenoise
           30  +package require TclOO
           31  +
           32  +namespace eval ::cmdr {
           33  +    namespace export say
           34  +}
           35  +namespace eval ::cmdr::say {
           36  +    namespace export up down forw back \
           37  +	erase-screen erase-up erase-down \
           38  +	erase-line erase-back erase-forw \
           39  +	goto home line add line rewind lock-prefix clear-prefix \
           40  +	next animate barberpole percent progress-counter progress \
           41  +	operation \
           42  +	\
           43  +	auto-width barber-phases progress-phases larson-phases \
           44  +	slider-phases pulse-phases
           45  +
           46  +    namespace ensemble create
           47  +    namespace import ::cmdr::color
           48  +
           49  +    # State for "add", "lock-prefix", "clear-prefix", and "rewind"
           50  +    variable prefix {}
           51  +    variable pre    {}
           52  +}
           53  +
           54  +# # ## ### ##### ######## ############# #####################
           55  +
           56  +debug define cmdr/say
           57  +debug level  cmdr/say
           58  +debug prefix cmdr/say {[debug caller] | }
           59  +
           60  +# # ## ### ##### ######## ############# #####################
           61  +## cursor movement
           62  +
           63  +proc ::cmdr::say::up {{n 1}} {
           64  +    debug.cmdr/say {}
           65  +    puts -nonewline stdout \033\[${n}A
           66  +    flush           stdout
           67  +    return
           68  +}
           69  +
           70  +proc ::cmdr::say::down {{n 1}} {
           71  +    debug.cmdr/say {}
           72  +    puts -nonewline stdout \033\[${n}B
           73  +    flush           stdout
           74  +    return
           75  +}
           76  +
           77  +proc ::cmdr::say::forw {{n 1}} {
           78  +    debug.cmdr/say {}
           79  +    puts -nonewline stdout \033\[${n}C
           80  +    flush           stdout
           81  +    return
           82  +}
           83  +
           84  +proc ::cmdr::say::back {{n 1}} {
           85  +    debug.cmdr/say {}
           86  +    puts -nonewline stdout \033\[${n}D
           87  +    flush           stdout
           88  +    return
           89  +}
           90  +
           91  +# # ## ### ##### ######## ############# #####################
           92  +## (partial) screen erasure
           93  +
           94  +proc ::cmdr::say::erase-screen {{suffix {}}} {
           95  +    debug.cmdr/say {}
           96  +    puts -nonewline stdout \033\[2J$suffix
           97  +    flush           stdout
           98  +    return
           99  +}
          100  +
          101  +proc ::cmdr::say::erase-up {{suffix {}}} {
          102  +    debug.cmdr/say {}
          103  +    puts -nonewline stdout \033\[1J$suffix
          104  +    flush           stdout
          105  +    return
          106  +}
          107  +
          108  +proc ::cmdr::say::erase-down {{suffix {}}} {
          109  +    debug.cmdr/say {}
          110  +    puts -nonewline stdout \033\[0J$suffix
          111  +    flush           stdout
          112  +    return
          113  +}
          114  +
          115  +# # ## ### ##### ######## ############# #####################
          116  +## (partial) line erasure
          117  +
          118  +proc ::cmdr::say::erase-line {{suffix {}}} {
          119  +    debug.cmdr/say {}
          120  +    puts -nonewline stdout \033\[2K$suffix
          121  +    flush           stdout
          122  +    return
          123  +}
          124  +
          125  +proc ::cmdr::say::erase-back {{suffix {}}} {
          126  +    debug.cmdr/say {}
          127  +    puts -nonewline stdout \033\[1K$suffix
          128  +    flush           stdout
          129  +    return
          130  +}
          131  +
          132  +proc ::cmdr::say::erase-forw {{suffix {}}} {
          133  +    debug.cmdr/say {}
          134  +    puts -nonewline stdout \033\[0K$suffix
          135  +    flush           stdout
          136  +    return
          137  +}
          138  +
          139  +# # ## ### ##### ######## ############# #####################
          140  +## absolute cursor movement
          141  +
          142  +proc ::cmdr::say::goto {x y} {
          143  +    debug.cmdr/say {}
          144  +    puts -nonewline stdout \033\[${y};${x}f
          145  +    flush           stdout
          146  +    return
          147  +}
          148  +
          149  +proc ::cmdr::say::home {} {
          150  +    debug.cmdr/say {}
          151  +    puts -nonewline stdout \033\[H
          152  +    flush           stdout
          153  +    return
          154  +}
          155  +
          156  +# # ## ### ##### ######## ############# #####################
          157  +## bottom level line output and animation control
          158  +
          159  +proc ::cmdr::say::add {text} {
          160  +    debug.cmdr/say {}
          161  +    variable pre
          162  +    append   pre $text
          163  +    puts -nonewline stdout $text
          164  +    flush           stdout
          165  +    return
          166  +}
          167  +
          168  +proc ::cmdr::say::line {text} {
          169  +    debug.cmdr/say {}
          170  +    variable pre    {}
          171  +    variable prefix {}
          172  +    puts  stdout $text
          173  +    flush stdout
          174  +    return
          175  +}
          176  +
          177  +proc ::cmdr::say::rewind {} {
          178  +    debug.cmdr/say {}
          179  +    variable prefix
          180  +    erase-line \r$prefix
          181  +    return
          182  +}
          183  +
          184  +proc ::cmdr::say::lock-prefix {} {
          185  +    debug.cmdr/say {}
          186  +    variable pre
          187  +    variable prefix $pre
          188  +    return
          189  +}
          190  +
          191  +proc ::cmdr::say::clear-prefix {} {
          192  +    debug.cmdr/say {}
          193  +    variable prefix {}
          194  +    return
          195  +}
          196  +
          197  +proc ::cmdr::say::next {} {
          198  +    debug.cmdr/say {}
          199  +    clear-prefix
          200  +    puts  stdout ""
          201  +    flush stdout
          202  +    return
          203  +}
          204  +
          205  +# # ## ### ##### ######## ############# #####################
          206  +
          207  +proc ::cmdr::say::operation {lead script} {
          208  +    debug.cmdr/say {}
          209  +    add $lead
          210  +
          211  +    uplevel 1 $script
          212  +
          213  +    line [color good OK]
          214  +    return
          215  +}
          216  +
          217  +# # ## ### ##### ######## ############# #####################
          218  +## general animation command and class
          219  +
          220  +proc ::cmdr::say::animate {args} {
          221  +    debug.cmdr/say {}
          222  +    array set config $args
          223  +    Require config -phases
          224  +    return [animate::Im new -phases [Fill $config(-phases)]]
          225  +}
          226  +
          227  +oo::class create ::cmdr::say::animate::Im {
          228  +    variable myphases myphase mywidth
          229  +
          230  +    constructor {args} {
          231  +	debug.cmdr/say {}
          232  +	my configure {*}$args
          233  +	return
          234  +    }
          235  +
          236  +    method configure {args} {
          237  +	array set config $args
          238  +	::cmdr::say::Require config -phases
          239  +
          240  +	set myphases $config(-phases)
          241  +	set myphase  0
          242  +	set mywidth  [string length [lindex $myphases 0]]
          243  +	return
          244  +    }
          245  +
          246  +    method width {} {
          247  +	debug.cmdr/say {}
          248  +	return $mywidth
          249  +    }
          250  +
          251  +    method step {} {
          252  +	debug.cmdr/say {}
          253  +	cmdr say add [lindex $myphases $myphase]
          254  +	incr myphase
          255  +	if {$myphase == [llength $myphases]} { set myphase 0 }
          256  +	return
          257  +    }
          258  +
          259  +    method goto {phase} {
          260  +	debug.cmdr/say {}
          261  +	set myphase $phase
          262  +	cmdr say add [lindex $myphases $myphase]
          263  +	return
          264  +    }
          265  +
          266  +    method done {} {
          267  +	debug.cmdr/say {}
          268  +	my destroy
          269  +    }
          270  +}
          271  +
          272  +# # ## ### ##### ######## ############# #####################
          273  +## barberpole animation
          274  +
          275  +proc ::cmdr::say::barberpole {args} {
          276  +    debug.cmdr/say {}
          277  +
          278  +    array set config {
          279  +	-width   {}
          280  +	-pattern {**  }
          281  +    }
          282  +    array set config $args
          283  +
          284  +    set phases [barber-phases \
          285  +		    [auto-width $config(-width)] \
          286  +		    $config(-pattern)]
          287  +
          288  +    # Run the animation via the general class.
          289  +    return [animate::Im new -phases $phases]
          290  +}
          291  +
          292  +# # ## ### ##### ######## ############# #####################
          293  +## progress counter, n of max.
          294  +
          295  +proc ::cmdr::say::progress-counter {max} {
          296  +    debug.cmdr/say {}
          297  +    return [progress-counter::Im new $max]
          298  +}
          299  +
          300  +oo::class create ::cmdr::say::progress-counter::Im {
          301  +    variable mywidth myformat mymax
          302  +
          303  +    constructor {max} {
          304  +	debug.cmdr/say {}
          305  +	set n [string length $max]
          306  +	set mymax    $max
          307  +	set mywidth  [expr {1+2*$n}]
          308  +	set myformat %${n}d/%d
          309  +	return
          310  +    }
          311  +
          312  +    method width {} {
          313  +	debug.cmdr/say {}
          314  +	return $mywidth
          315  +    }
          316  +
          317  +    method step {at} {
          318  +	debug.cmdr/say {}
          319  +	cmdr say add [format $myformat $at $mymax]
          320  +	return
          321  +    }
          322  +
          323  +    method done {} {
          324  +	debug.cmdr/say {}
          325  +	my destroy
          326  +    }
          327  +}
          328  +
          329  +# # ## ### ##### ######## ############# #####################
          330  +## progress counter, in percent.
          331  +
          332  +proc ::cmdr::say::percent {args} {
          333  +    debug.cmdr/say {}
          334  +
          335  +    array set config {
          336  +	-max    100
          337  +	-digits 2
          338  +    }
          339  +    array set config $args
          340  +
          341  +    return [percent::Im new $config(-max) $config(-digits)]
          342  +}
          343  +
          344  +oo::class create ::cmdr::say::percent::Im {
          345  +    variable mywidth myformat mymax
          346  +
          347  +    constructor {max digits} {
          348  +	debug.cmdr/say {}
          349  +	set mymax $max
          350  +
          351  +	set mywidth 3
          352  +	if {$digits} {
          353  +	    incr mywidth ;# .
          354  +	    incr mywidth $digits
          355  +	}
          356  +	set myformat %${mywidth}.${digits}f
          357  +	return
          358  +    }
          359  +
          360  +    method width {} {
          361  +	debug.cmdr/say {}
          362  +	return $mywidth
          363  +    }
          364  +
          365  +    method step {at} {
          366  +	debug.cmdr/say {}
          367  +	set percent [expr {100*double($at)/double($mymax)}]
          368  +	cmdr say add [format $myformat $percent]%
          369  +	return
          370  +    }
          371  +
          372  +    method done {} {
          373  +	debug.cmdr/say {}
          374  +	my destroy
          375  +    }
          376  +}
          377  +
          378  +# # ## ### ##### ######## ############# #####################
          379  +## progress-bar
          380  +
          381  +proc ::cmdr::say::progress {args} {
          382  +    debug.cmdr/say {}
          383  +
          384  +    array set config {
          385  +	-max    100
          386  +	-width  {}
          387  +	-stem   =
          388  +	-head   >
          389  +    }
          390  +    array set config $args
          391  +
          392  +    set phases [progress-phases \
          393  +		    [auto-width $config(-width)] \
          394  +		    $config(-stem) \
          395  +		    $config(-head)]
          396  +
          397  +    return [progress::Im new $config(-max) $phases]
          398  +}
          399  +
          400  +oo::class create ::cmdr::say::progress::Im {
          401  +    variable mymax myphases
          402  +
          403  +    constructor {max phases} {
          404  +	debug.cmdr/say {}
          405  +	# Inner object, general animation, container for our phases.
          406  +	cmdr::say::animate::Im create A -phases $phases
          407  +	set mymax    $max
          408  +	set myphases [llength $phases]
          409  +	return
          410  +    }
          411  +
          412  +    forward width \
          413  +	A width
          414  +
          415  +    method step {at} {
          416  +	debug.cmdr/say {}
          417  +	set phase [expr {int($myphases * (double($at)/double($mymax)))}]
          418  +	if {$phase >= $myphases} { set phase end }
          419  +	A goto $phase
          420  +	return
          421  +    }
          422  +
          423  +    method done {} {
          424  +	debug.cmdr/say {}
          425  +	my destroy
          426  +    }
          427  +}
          428  +
          429  +# # ## ### ##### ######## ############# #####################
          430  +
          431  +proc ::cmdr::say::auto-width {width} {
          432  +    debug.cmdr/say {}
          433  +
          434  +    if {$width eq {}} {
          435  +	# Nothing defined, adapt to terminal width
          436  +	set width [linenoise columns]
          437  +    } elseif {$width < 0} {
          438  +	# Adapt to terminal width, with some space reserved.
          439  +	set width [expr {[linenoise columns] + $width}]
          440  +    }
          441  +    return $width
          442  +}
          443  +
          444  +# # ## ### ##### ######## ############# #####################
          445  +
          446  +proc ::cmdr::say::barber-phases {width pattern} {
          447  +    debug.cmdr/say {}
          448  +
          449  +    # Repeat the base pattern as necessary to fill the requested
          450  +    # width. We use a count which gives us something which might be a
          451  +    # bit over, so after replication the resulting string is cut down
          452  +    # to the exact size.
          453  +    set n    [expr {int(0.5+ceil($width / double([string length $pattern])))}]
          454  +    set base [string range [string repeat $pattern $n] 0 ${width}-1]
          455  +
          456  +    # Example for standard pattern '**  ', widths 16, and 17.
          457  +    # |**  **  **  **  |
          458  +    # | **  **  **  ** |
          459  +    # |  **  **  **  **|
          460  +    # |*  **  **  **  *|
          461  +
          462  +    # |**  **  **  **  *| Note how the odd length yields one larger
          463  +    # |***  **  **  **  | band (***) in the pattern, which ripples
          464  +    # | ***  **  **  ** | across, and multiplies the number of phases
          465  +    # |  ***  **  **  **| before reaching the origin again.
          466  +    # |*  ***  **  **  *|
          467  +    # |**  ***  **  **  | Similar effects will be had for for any width
          468  +    # | **  ***  **  ** | which W != 0 mod (length pattern).
          469  +    # |  **  ***  **  **|
          470  +    # |*  **  ***  **  *|
          471  +    # |**  **  ***  **  |
          472  +    # | **  **  ***  ** |
          473  +    # |  **  **  ***  **|
          474  +    # |*  **  **  ***  *|
          475  +    # |**  **  **  ***  |
          476  +    # | **  **  **  *** |
          477  +    # |  **  **  **  ***|
          478  +    # |*  **  **  **  **|
          479  +
          480  +    lappend phases $base
          481  +    # rotate the base through all configurations until we reach it again.
          482  +    set next $base
          483  +    while {1} {
          484  +	set next [string range $next 1 end][string index $next 0]
          485  +	if {$next eq $base} break
          486  +	lappend phases $next
          487  +    }
          488  +
          489  +    return $phases
          490  +}
          491  +
          492  +proc ::cmdr::say::progress-phases {width stem head} {
          493  +    debug.cmdr/say {}
          494  +
          495  +    # compute phases.
          496  +    set h [string length $head]
          497  +    set phases {}
          498  +    for {set i 0} {$i < ($width - $h)} {incr i} {
          499  +	lappend phases [string repeat $stem $i]$head
          500  +	# >, =>, ==>, ...
          501  +    }
          502  +
          503  +    return [Fill $phases]
          504  +}
          505  +
          506  +proc ::cmdr::say::larson-phases {width pattern} {
          507  +    debug.cmdr/say {}
          508  +
          509  +    set n [string length $pattern]
          510  +    if {$n > $width} {
          511  +	return [list $pattern]
          512  +    }
          513  +
          514  +    set spaces [expr {$width - $n}]
          515  +
          516  +    # round 1: slide right
          517  +    for {
          518  +	set pre  0
          519  +	set post $spaces
          520  +    } { $post > 0 } {
          521  +	incr pre
          522  +	incr post -1
          523  +    } {
          524  +	lappend phases [string repeat { } $pre]${pattern}[string repeat { } $post]
          525  +    }
          526  +
          527  +    # round 2: slide left
          528  +    for {
          529  +	set pre  $spaces
          530  +	set post 0
          531  +    } { $pre > 0 } {
          532  +	incr pre  -1
          533  +	incr post
          534  +    } {
          535  +	lappend phases [string repeat { } $pre]${pattern}[string repeat { } $post]
          536  +    }
          537  +
          538  +    return $phases
          539  +}
          540  +
          541  +proc ::cmdr::say::slider-phases {width pattern} {
          542  +    debug.cmdr/say {}
          543  +
          544  +    set n [string length $pattern]
          545  +    if {$n > $width} {
          546  +	return [list $pattern]
          547  +    }
          548  +
          549  +    # round 1: slide pattern in.
          550  +    lappend phases {}
          551  +    for {set k 0} {$k < $n} {incr k} {
          552  +	lappend phases [string range $pattern end-$k end]
          553  +    }
          554  +
          555  +    # round 2: slide pattern right.
          556  +    set spaces [expr {$width - $n}]
          557  +    for {
          558  +	set pre  0
          559  +	set post $spaces
          560  +    } { $post > 0 } {
          561  +	incr pre
          562  +	incr post -1
          563  +    } {
          564  +	lappend phases [string repeat { } $pre]${pattern}[string repeat { } $post]
          565  +    }
          566  +
          567  +    # round 3: slide pattern out.
          568  +    for {set k 0} {$k < $n} {incr k} {
          569  +	lappend phases [string repeat { } $pre][string range $pattern 0 end-$k]
          570  +	incr pre
          571  +    }
          572  +
          573  +    return $phases
          574  +}
          575  +
          576  +proc ::cmdr::say::pulse-phases {width stem} {
          577  +    debug.cmdr/say {}
          578  +
          579  +    # compute phases.
          580  +    set phases {}
          581  +    for {set i 0} {$i <= $width} {incr i} {
          582  +	lappend phases [string repeat $stem $i]
          583  +    }
          584  +    return [Fill $phases]
          585  +}
          586  +
          587  +# # ## ### ##### ######## ############# #####################
          588  +
          589  +proc ::cmdr::say::Require {cv option} {
          590  +    debug.cmdr/say {}
          591  +    upvar 1 $cv config
          592  +    if {[info exists config($option)]} return
          593  +    return -code error \
          594  +	-errorCode [list CMDR SAY OPTION MISSING $option] \
          595  +	"Missing required option \"$option\""
          596  +}
          597  +
          598  +proc ::cmdr::say::Fill {phases} {
          599  +    # compute max length of phase strings
          600  +    set max [string length [lindex $phases 0]]
          601  +    foreach p [lrange $phases 1 end] {
          602  +	# Look for ANSI color control sequences and remove them. Avoid
          603  +	# counting their characters as such sequences as a whole
          604  +	# represent a state change, and are logically of zero/no
          605  +	# width.
          606  +	regsub -all "\033\\\[\[0-9;\]*m" $p {} p
          607  +	set n [string length $p]
          608  +	if {$n < $max} continue
          609  +	set max $n
          610  +    }
          611  +
          612  +    # then pad all other strings which do not reach that length with
          613  +    # spaces at the end.
          614  +    set tmp {}
          615  +    foreach p $phases {
          616  +	# Look for ANSI color control sequences and discount
          617  +	# them. Avoid counting their characters as such sequences as a
          618  +	# whole represent a state change, and are logically of zero/no
          619  +	# width.
          620  +	regsub -all "\033\\\[\[0-9;\]*m" $p {} px
          621  +	set n [string length $px]
          622  +	if {$n < $max} {
          623  +	    append p [string repeat { } [expr {$max - $n}]]
          624  +	}
          625  +	lappend tmp $p
          626  +    }
          627  +
          628  +    return $tmp
          629  +}
          630  +
          631  +# # ## ### ##### ######## ############# #####################
          632  +## Ready
          633  +package provide cmdr::say 1