#! /local/bin/tclsh8.0

#
# Test data
#

set pipa1 "\"a a\" b b blah
\"c\" you"
set pipa2 "\"a a\" a b b
\"blah\" c
is. punctuation See text, This with? you!"
set pipa3 "am doing!
\"I my\", Oh punctuation this why With?"

#
# pipa1 : 0-1-0-0-1-1-0 (64)
# pipa3 : 8-5-4-3-4-0-1-0-0
#

#
# ----------------------------------------------------------------------
# Helper functions to handle huge numbers
# ----------------------------------------------------------------------
#

proc fak {n} {
    set exp 0
    set base 0
    for {set i 1} {$i <= $n} {incr i} {
	set base [expr $base + log10($i)]
	set nexp [expr floor($base)]
	set exp  [expr $exp + $nexp]
	set base [expr $base - $nexp]
    }
    return "[expr exp($base*log(10.0))] [expr int($exp)]"
}

proc mult {f1 f2} {
    set base [expr log10([lindex $f1 0]) + log10([lindex $f2 0])]
    set nexp [expr floor($base)]
    set exp  [expr [lindex $f1 1] + [lindex $f2 1] + $nexp]
    set base [expr $base - $nexp]
    return "[expr exp($base*log(10.0))] [expr int($exp)]"
}

proc div {f1 f2} {
    set base [expr log10([lindex $f1 0]) - log10([lindex $f2 0])]
    set nexp [expr floor($base)]
    set exp  [expr [lindex $f1 1] - [lindex $f2 1] + $nexp]
    set base [expr $base - $nexp]
    return "[expr exp($base*log(10.0))] [expr int($exp)]"
}

#
# ----------------------------------------------------------------------
# Handle lists of words
# ----------------------------------------------------------------------
#
# uniq: return list of unique words in a (sorted) list
# card: return cardinality of a word in a list
#

proc uniq {l} {
    set last ""
    set result ""
    foreach w $l {
	if {$w != $last} {
	    lappend result [set last $w]
	}
    }
    return $result
}

proc card {l w} {
    set c 0
    foreach i $l {
	if {$i == $w} {
	    incr c
	}
    }
    return $c
}

proc fastcard {l} {
    global wordcount
    if [info exists wordcount] {
	unset wordcount
    }
    foreach w $l {
	if [info exists wordcount($w)] {
	    incr wordcount($w)
	} else {
	    set wordcount($w) 1
	}
    }
}

#
# ----------------------------------------------------------------------
# Compute number of possible permutations
# ----------------------------------------------------------------------
#
# That's the factorial of the total number of words divided by the
# product of all cardinalities of the unique words
#

proc perms {awords uwords} {
    global wordcount
    set total  [fak [llength $awords]]
    set cards  {1 0}
    fastcard $awords
    foreach word $uwords {
	set cards [mult $cards [fak $wordcount($word)]]
    }
    return [join [div $total $cards] e]
}

#
# ----------------------------------------------------------------------
# Main function
# ----------------------------------------------------------------------
#
# recursively substitutes the next word in pip with all words from
# awords. index is the current index into pip where the next word
# is to be replaced, total is the composed text so far, and log
# traces the permutation
#

proc antipipa_rek {pip awords index total log} {
    global count result mapping

    if {[set word [string range $pip $index [expr [set next [string wordend $pip $index]] - 1]]] == ""} {
	incr count
#	set result($count) $total
#	set mapping([join $log -]) $count
	puts "Possibility #$count ([join $log -])\n---\n$total\n---"
#	puts -nonewline "Possibility #$count ([join $log -])\r"
    } elseif [regexp {[0-9A-Za-z]} $word] {
	set last ""
	set i 0
	foreach repl $awords {
	    if {$repl != $last} {
		set last $repl
		set rest [lreplace $awords $i $i]
		regsub {[0-9A-Za-z]+} $word $repl nword
		antipipa_rek $pip $rest $next $total$nword [concat $log $i]
	    }
	    incr i
	}
    } else {
	antipipa_rek $pip $awords $next $total$word $log
    }
}

#
# recursion setup
#

proc antipipa {pip} {
    global count
    set count 0
    regsub -all {[^0-9A-Za-z \n\r]} $pip " " words
    set awords [lsort $words]
    antipipa_rek $pip $awords 0 "" ""
#    puts "\r\ndone."
}

proc showinfo {pip} {
    regsub -all {[^0-9A-Za-z \n\r]} $pip " " words
    set awords [lsort $words]
    set uwords [uniq $awords]
    puts "[llength $awords] words, [llength $uwords] unique, [perms $awords $uwords] permutaions ..."
}

#set f [open allpages]
#set titanic [read $f]
#close $f

set titanic [read stdin]
showinfo $titanic
antipipa $titanic