package provide patterncmd  [namespace eval patterncmd {
	variable version 

	set version 1.2.4
}]


namespace eval pattern {
    variable idCounter 1  ;#used by pattern::uniqueKey 

    namespace eval cmd {
        namespace eval util {
            package require overtype
            variable colwidths_lib [dict create]
            variable colwidths_lib_default 15
     
            dict set colwidths_lib "library"    [list ch " " num 21 head "|" tail ""]
            dict set colwidths_lib "version"    [list ch " " num 7  head "|" tail ""]
            dict set colwidths_lib "type"       [list ch " " num 9  head "|" tail ""]
            dict set colwidths_lib "note"       [list ch " " num 31 head "|" tail "|"]
            
            proc colhead {type args} {
                upvar #0 ::pattern::cmd::util::colwidths_$type colwidths
                set line ""
                foreach colname [dict keys $colwidths] {
                    append line "[col $type $colname [string totitle $colname] {*}$args]"
                }
                return $line
            }
            proc colbreak {type} {
                upvar #0 ::pattern::cmd::util::colwidths_$type colwidths
                set line ""
                foreach colname [dict keys $colwidths] {
                    append line "[col $type $colname {} -backchar - -headoverridechar + -tailoverridechar +]"
                }
                return $line
            }
            proc col {type col val args} {
                # args -head bool  -tail bool ?
                  #----------------------------------------------------------------------------
                set known_opts [list -backchar -headchar -tailchar -headoverridechar -tailoverridechar -justify] 
                dict set default -backchar "" 
                dict set default -headchar ""
                dict set default -tailchar ""
                dict set default -headoverridechar ""
                dict set default -tailoverridechar ""
                dict set default -justify "left"
                if {([llength $args] % 2) != 0} {
                    error "(pattern::cmd::util::col) ERROR: uneven options supplied - must be of form '-option value' "
                }
                foreach {k v} $args {
                    if {$k ni $known_opts} {
                        error "((pattern::cmd::util::col) ERROR: option '$k' not in known options: '$known_opts'"
                    }
                }
                set opts [dict merge $default $args]
                set backchar    [dict get $opts -backchar]
                set headchar    [dict get $opts -headchar]
                set tailchar    [dict get $opts -tailchar]
                set headoverridechar    [dict get $opts -headoverridechar]
                set tailoverridechar    [dict get $opts -tailoverridechar]
                set justify    [dict get $opts -justify]
                #----------------------------------------------------------------------------
                
                
                
                upvar #0 ::pattern::cmd::util::colwidths_$type colwidths
                #calculate headwidths
                set headwidth 0
                set tailwidth 0
                foreach {key def} $colwidths {
                    set thisheadlen [string length [dict get $def head]]
                    if {$thisheadlen > $headwidth} {
                        set headwidth $thisheadlen
                    }
                    set thistaillen [string length [dict get $def tail]]
                    if {$thistaillen > $tailwidth} {
                        set tailwidth $thistaillen
                    }
                }                
                
                
                set spec [dict get $colwidths $col]
                if {[string length $backchar]} {
                    set ch   $backchar 
                } else {
                    set ch   [dict get $spec ch]
                }
                set num  [dict get $spec num]
                set headchar [dict get $spec head]
                set tailchar [dict get $spec tail]
                
                if {[string length $headchar]} {
                    set headchar $headchar
                }
                if {[string length $tailchar]} {
                    set tailchar $tailchar
                }
                #overrides only apply if the head/tail has a length
                if {[string length $headchar]} {
                    if {[string length $headoverridechar]} {
                        set headchar $headoverridechar 
                    }
                }
                if {[string length $tailchar]} {
                    if {[string length $tailoverridechar]} {
                        set tailchar $tailoverridechar
                    }
                }
                set head [string repeat $headchar $headwidth]
                set tail [string repeat $tailchar $tailwidth]
                
                set base [string repeat $ch [expr {$headwidth + $num + $tailwidth}]]
                if {$justify eq "left"} {
                    set left_done [overtype::left $base "$head$val"]
                    return   [overtype::right $left_done "$tail"]
                } elseif {$justify in {centre center}} {
                    set mid_done [overtype::centre $base $val]
                    set left_mid_done [overtype::left $mid_done $head]
                    return   [overtype::right $left_mid_done $tail]
                } else {
                    set right_done [overtype::right $base "$val$tail"]
                    return [overtype::left $right_done $head]
                }
                
            }
        
        }
    }
    
}

#package require pattern 

proc ::pattern::libs {} {
    set libs [list \
    pattern            {-type core -note "alternative:pattern2"}\
    pattern2           {-type core -note "alternative:pattern"}\
    patterncmd         {-type core}\
    metaface           {-type core}\
    patternpredator2   {-type core}\
    patterndispatcher  {-type core}\
    patternlib         {-type core}\
    patterncipher      {-type optional -note optional}\
    ]
    
    
    
    package require overtype
    set result ""
    
    append result "[cmd::util::colbreak lib]\n"
    append result "[cmd::util::colhead lib -justify centre]\n"
    append result "[cmd::util::colbreak lib]\n"
    foreach libname [dict keys $libs] {
        set libinfo [dict get $libs $libname]
        
         append result          [cmd::util::col lib library $libname]
         if {[catch [list package present $libname] ver]} {
            append result       [cmd::util::col lib version "N/A"]
         } else {
            append result       [cmd::util::col lib version $ver]
         }
         append result          [cmd::util::col lib type [dict get $libinfo -type]]
         
         if {[dict exists $libinfo -note]} {
            set note [dict get $libinfo -note]
         } else {
            set note ""
         }
         append result          [cmd::util::col lib note $note]
         append result "\n"
    }    
    append result "[cmd::util::colbreak lib]\n"
    return $result
}

proc ::pattern::record {recname fields} {
    if {[uplevel 1 [list namespace which $recname]] ne ""} {
        error "(pattern::record) Can't create command '$recname': A command of that name already exists"
    }
    
    set index -1
    set accessor [list ::apply {
        {index rec args}
        {
            if {[llength $args] == 0} {
                return [lindex $rec $index]
            }
            if {[llength $args] == 1} {
                return [lreplace $rec $index $index [lindex $args 0]]
            }
            error "Invalid number of arguments."
        }

    }]
    
    set map {}
    foreach field  $fields {
        dict set map $field [linsert $accessor end [incr index]]
    }
    uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec]
}
proc ::pattern::record2 {recname fields} {
    if {[uplevel 1 [list namespace which $recname]] ne ""} {
        error "(pattern::record) Can't create command '$recname': A command of that name already exists"
    }
    
    set index -1
    set accessor [list ::apply]
    
    set template {
        {rec args}
        {
            if {[llength $args] == 0} {
                return [lindex $rec %idx%]
            }
            if {[llength $args] == 1} {
                return [lreplace $rec %idx% %idx% [lindex $args 0]]
            }
            error "Invalid number of arguments."
        }
    }
    
    set map {}
    foreach field  $fields {
        set body [string map [list %idx% [incr index]] $template]
        dict set map $field [list ::apply $body]
    }
    uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec]
}

proc ::argstest {args} {
    package require cmdline

}

proc ::pattern::objects {} {
    set result [::list]
    
    foreach ns [namespace children ::pp] {
        #lappend result [::list [namespace tail $ns] [set ${ns}::(self)]]
        set ch [namespace tail $ns]
        if {[string range $ch 0 2] eq "Obj"} {
            set OID [string range $ch 3 end] ;#OID need not be digits (!?)
            lappend result [::list $OID [list OID $OID object_command [set pp::${ch}::v_object_command] usedby [array names ${ns}::_iface::o_usedby]]]
        }
    }
    
    
    
    
    return $result
}



proc ::pattern::name {num} {
	#!todo - fix
	#set ::p::${num}::(self)

	lassign [interp alias {} ::p::$num] _predator info
	if {![string length $_predator$info]} {
		error "No object found for num:$num (no interp alias for ::p::$num)"
	}
	set invocants [dict get $info i]
	set invocants_with_role_this [dict get $invocants this]
	set invocant_this [lindex $invocants_with_role_this 0]
	
	
	#lassign $invocant_this id info
	#set map [dict get $info map]
	#set fields [lindex $map 0]
	lassign $invocant_this _id _ns _defaultmethod name _etc
	return $name
}


proc ::pattern::with {cmd script} {
	foreach c [info commands ::p::-1::*] {
		interp alias {} [namespace tail $c] {} $c $cmd
	}		
	interp alias {} . {} $cmd .
	interp alias {} .. {} $cmd ..

	return [uplevel 1 $script]
}





#system diagnostics etc

proc ::pattern::varspace_list {IID} {
    namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_variables o_variables    

    set varspaces [list]
    dict for {vname vdef} $o_variables {
        set vs [dict get $vdef varspace]
        if {$vs ni $varspaces} {
            lappend varspaces $vs
        }
    }
    if {$o_varspace ni $varspaces} {
        lappend varspaces $o_varspace
    }
    return $varspaces
}

proc ::pattern::check_interfaces {} {
	foreach ns [namespace children ::p] {
		set IID [namespace tail $ns]
		if {[string is digit $IID]} {
			foreach ref [array names ${ns}::_iface::o_usedby] {
				set OID [string range $ref 1 end]
				if {![namespace exists ::p::${OID}::_iface]} {
					puts -nonewline stdout "\r\nPROBLEM!!!!!!!!!  nonexistant/invalid object $OID referenced by Interface $IID\r\n"
				} else {
					puts -nonewline stdout .
				}


				#if {![info exists ::p::${OID}::(self)]} {
				#	puts "PROBLEM!!!!!!!!!  nonexistant object $OID referenced by Interface $IID"
				#}
			}
		}
	}
	puts -nonewline stdout "\r\n"
}


#from: http://wiki.tcl.tk/8766  (Introspection on aliases)
#usedby: metaface-1.1.6+
#required because aliases can be renamed. 
#A renamed alias will still return it's target with 'interp alias {} oldname'
# - so given newname - we require which_alias to return the same info.
 proc ::pattern::which_alias {cmd} {
    uplevel 1 [list ::trace add execution $cmd enterstep ::error]
    catch {uplevel 1 $cmd} res
    uplevel 1 [list ::trace remove execution $cmd enterstep ::error]
    #puts stdout "which_alias $cmd returning '$res'"
    return $res
 }
# [info args] like proc following an alias recursivly until it reaches
# the proc it originates from or cannot determine it. 
# accounts for default parameters set by interp alias
#



proc ::pattern::aliasargs {cmd} {
		set orig $cmd
			
		set defaultargs [list] 
		
		# loop until error or return occurs
		while {1} {
			# is it a proc already?
			if {[string equal [info procs $cmd] $cmd]} {
				set result [info args $cmd] 
				# strip off the interp set default args
				return [lrange $result [llength $defaultargs] end]
			} 
			# is it a built in or extension command we can get no args for?
			if {![string equal [info commands $cmd] $cmd]} {
				error "\"$orig\" isn't a procedure"
			}
			
			# catch bogus cmd names 
			if {[lsearch [interp aliases {}] $cmd]==-1} {
				if {[catch {::pattern::which_alias $cmd} alias]} {
					error "\"$orig\" isn't a procedure or alias or command" 
				} 
				#set cmd [lindex $alias 0]
				if {[llength $alias]>1} {
					set cmd [lindex $alias 0]
					set defaultargs [concat [lrange $alias 1 end] $defaultargs]
				} else {
					set cmd $alias
				}
			} else {
				
				if {[llength [set cmdargs [interp alias {} $cmd]]]>0} {
					# check if it is aliased in from another interpreter
					if {[catch {interp target {} $cmd} msg]} {
						error "Cannot resolve \"$orig\", alias leads to another interpreter."
					}
					if {$msg != {} } {
						error "Not recursing into slave interpreter \"$msg\".\
							   \"$orig\" could not be resolved."
					}
					# check if defaults are set for the alias
					if {[llength $cmdargs]>1} {
						set cmd [lindex $cmdargs 0]
						set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs]
					} else {
						set cmd $cmdargs
					}
				}
			} 
		}             
 }
proc ::pattern::aliasbody {cmd} {
		set orig $cmd
			
		set defaultargs [list] 
		
		# loop until error or return occurs
		while {1} {
			# is it a proc already?
			if {[string equal [info procs $cmd] $cmd]} {
				set result [info body $cmd] 
				# strip off the interp set default args
				return $result
				#return [lrange $result [llength $defaultargs] end]
			} 
			# is it a built in or extension command we can get no args for?
			if {![string equal [info commands $cmd] $cmd]} {
				error "\"$orig\" isn't a procedure"
			}
			
			# catch bogus cmd names 
			if {[lsearch [interp aliases {}] $cmd]==-1} {
				if {[catch {::pattern::which_alias $cmd} alias]} {
					error "\"$orig\" isn't a procedure or alias or command" 
				} 
				#set cmd [lindex $alias 0]
				if {[llength $alias]>1} {
					set cmd [lindex $alias 0]
					set defaultargs [concat [lrange $alias 1 end] $defaultargs]
				} else {
					set cmd $alias
				}
			} else {
				
				if {[llength [set cmdargs [interp alias {} $cmd]]]>0} {
					# check if it is aliased in from another interpreter
					if {[catch {interp target {} $cmd} msg]} {
						error "Cannot resolve \"$orig\", alias leads to another interpreter."
					}
					if {$msg != {} } {
						error "Not recursing into slave interpreter \"$msg\".\
							   \"$orig\" could not be resolved."
					}
					# check if defaults are set for the alias
					if {[llength $cmdargs]>1} {
						set cmd [lindex $cmdargs 0]
						set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs]
					} else {
						set cmd $cmdargs
					}
				}
			} 
		}             
 }





proc ::pattern::uniqueKey2 {} {
	#!todo - something else??
	return [clock seconds]-[incr ::pattern::idCounter]
}

#used by patternlib package
proc ::pattern::uniqueKey {} {
	return [incr ::pattern::idCounter]
	#uuid with tcllibc is about 30us compared with 2us
	# for large datasets, e.g about 100K inserts this would be pretty noticable!
	#!todo - uuid pool with background thread to repopulate when idle?
	#return [uuid::uuid generate]
}

 
 
#-------------------------------------------------------------------------------------------------------------------------

proc ::pattern::test1 {} {
	set msg "OK"

	puts stderr "next line should say:'--- saystuff:$msg"
	::>pattern .. Create ::>thing
	
	::>thing .. PatternMethod saystuff args {
		puts stderr "--- saystuff: $args"
	}
	::>thing .. Create ::>jjj
	
	::>jjj . saystuff $msg
	::>jjj .. Destroy
	::>thing .. Destroy
}

proc ::pattern::test2 {} {
	set msg "OK"

	puts stderr "next line should say:'--- property 'stuff' value:$msg"
	::>pattern .. Create ::>thing
	
	::>thing .. PatternProperty stuff $msg
	
	::>thing .. Create ::>jjj
	
	puts stderr "--- property 'stuff' value:[::>jjj . stuff]"
	::>jjj .. Destroy
	::>thing .. Destroy
}

proc ::pattern::test3 {} {
	set msg "OK"

	puts stderr "next line should say:'--- property 'stuff' value:$msg"
	::>pattern .. Create ::>thing
	
	::>thing .. Property stuff $msg
	
	puts stderr "--- property 'stuff' value:[::>thing . stuff]"
	::>thing .. Destroy
}

#---------------------------------
#unknown/obsolete








#proc ::p::internals::showargs {args {ch stdout}} {puts $ch $args}
if {0} {
	proc ::p::internals::new_interface {{usedbylist {}}} {
		set OID [incr ::p::ID]
		::p::internals::new_object ::p::ifaces::>$OID "" $OID
		puts "obsolete >> new_interface created object $OID"	
		foreach usedby $usedbylist {
			set			::p::${OID}::_iface::o_usedby(i$usedby) 1
		}
		set         ::p::${OID}::_iface::o_varspace ""        ;#default varspace is the object's namespace. (varspace is absolute if it has leading :: , otherwise it's a relative namespace below the object's namespace)
		#NOTE - o_varspace is only the default varspace for when new methods/properties are added.
		# it is possible to create some methods/props with one varspace value, then create more methods/props with a different varspace value.

		set 	  	::p::${OID}::_iface::o_constructor [list] 
		set 	  	::p::${OID}::_iface::o_variables [list]
		set 	  	::p::${OID}::_iface::o_properties [dict create]
		set 	  	::p::${OID}::_iface::o_methods [dict create]
		array set 	::p::${OID}::_iface::o_definition [list]
		set 		::p::${OID}::_iface::o_open 1   ;#open for extending
		return $OID
	}

	
	#temporary way to get OID - assumes single 'this' invocant
	#!todo - make generic.
	proc ::pattern::get_oid {_ID_} {
		#puts stderr "#* get_oid: [lindex [dict get $_ID_ i this] 0 0]"
		return [lindex [dict get $_ID_ i this] 0 0]
		
		#set invocants [dict get $_ID_ i]
		#set invocant_roles [dict keys $invocants]
		#set role_members [dict get $invocants this] 
		##set this_invocant [lindex $role_members 0] ;#for the role 'this' we assume only one invocant in the list.
		#set this_invocant [lindex [dict get $_ID_ i this] 0] ;
		#lassign $this_invocant OID this_info
		#
		#return $OID
	}
	
	#compile the uncompiled level1 interface 
	#assert: no more than one uncompiled interface present at level1
	proc ::p::meta::PatternCompile {self} {
	????

		upvar #0 $self SELFMAP
		set ID		[lindex $SELFMAP 0 0]

		set patterns	[lindex $SELFMAP 1 1] ;#list of level1 interfaces

		set iid -1
		foreach i $patterns {
			if {[set ::p::${i}::_iface::o_open]} {
				set iid $i ;#found it
				break
			}
		}

		if {$iid > -1} {
			#!todo
		
			::p::compile_interface $iid
			set ::p::${iid}::_iface::o_open 0
		} else {
			#no uncompiled interface present at level 1. Do nothing.
			return
		}
	}

	
	proc ::p::meta::Def {self} {
        error ::p::meta::Def
        
		upvar #0 $self SELFMAP
		set self_ID	[lindex $SELFMAP 0 0]
		set IFID	[lindex $SELFMAP 1 0 end]

		set maxc1 0
		set maxc2 0
		
		set arrName ::p::${IFID}::
		
		upvar #0 $arrName state

		array set methods {}
			
		foreach nm [array names state] {
			if {[regexp {^m-1,name,(.+)} $nm _match mname]} {
				set methods($mname) [set state($nm)]

				if {[string length $mname] > $maxc1} {
					set maxc1 [string length $mname]
				}
				if {[string length [set state($nm)]] > $maxc2} {
					set maxc2 [string length [set state($nm)]]
				}
			}
		}
		set bg1 [string repeat " " [expr {$maxc1 + 2}]]
		set bg2 [string repeat " " [expr {$maxc2 + 2}]]
		

		set r {}
		foreach nm [lsort -dictionary [array names methods]] {
			set arglist $state(m-1,args,$nm)
			append r "[overtype::left $bg1 $nm] : [overtype::left $bg2 $methods($nm)] [::list $arglist]\n"
		}
		return $r		
	}


	
}