# ACTIVESTATE TEAPOT-PKG BEGIN TM -*- tcl -*-
# -- Tcl Module

# @@ Meta Begin
# Package stsatcl 1.0.3
# Meta category    Software Architecture
# Meta description The stsatcl package is a software execution architecture
# Meta description intended as the target for translating Executable UML
# Meta description (XUML) domain models into a running program using Tcl as
# Meta description the implementation language. The package is build upon a
# Meta description TclOO foundation and will on casual inspection appear as
# Meta description a higher order object system. Classes may be defined
# Meta description with attributes, relationships and state models. The
# Meta description execution semantics of XUML are provided in a form to
# Meta description make translation of a model onto stsatcl a direct and
# Meta description understandable operation. State machine event dispatch
# Meta description and state machine event tracing are provided to support
# Meta description implementing and testing the dynamic aspects of an XUML
# Meta description model. The documentation includes a complete running
# Meta description example showing how the process of translating the model
# Meta description to a running implementation happens.
# Meta platform    tcl
# Meta require     {Tcl 8.6}
# Meta require     logger
# Meta require     oo::util
# Meta require     ral
# Meta require     ralutil
# Meta require     struct::list
# Meta require     struct::set
# Meta require     textutil::adjust
# Meta subject     TclOO {XUML Object System}
# Meta summary     stsatcl - An Single Threaded Software Architecture for
# Meta summary     Tcl
# @@ Meta End


# ACTIVESTATE TEAPOT-PKG BEGIN REQUIREMENTS

package require Tcl 8.6
package require logger
package require oo::util
package require ral
package require ralutil
package require struct::list
package require struct::set
package require textutil::adjust

# ACTIVESTATE TEAPOT-PKG END REQUIREMENTS

# ACTIVESTATE TEAPOT-PKG BEGIN DECLARE

package provide stsatcl 1.0.3

# ACTIVESTATE TEAPOT-PKG END DECLARE
# ACTIVESTATE TEAPOT-PKG END TM
# DO NOT EDIT THIS FILE!
# THIS FILE IS AUTOMATICALLY GENERATED FROM A LITERATE PROGRAM SOURCE FILE.
#
# This software is copyrighted 2014 by G. Andrew Mangogna.
# The following terms apply to all files associated with the software unless
# explicitly disclaimed in individual files.
# 
# The authors hereby grant permission to use, copy, modify, distribute,
# and license this software and its documentation for any purpose, provided
# that existing copyright notices are retained in all copies and that this
# notice is included verbatim in any distributions. No written agreement,
# license, or royalty fee is required for any of the authorized uses.
# Modifications to this software may be copyrighted by their authors and
# need not follow the licensing terms described here, provided that the
# new terms are clearly indicated on the first page of each file where
# they apply.
# 
# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY FOR
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING
# OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY DERIVATIVES
# THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE POSSIBILITY OF
# SUCH DAMAGE.
# 
# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT.  THIS SOFTWARE
# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS,
# OR MODIFICATIONS.
# 
# GOVERNMENT USE: If you are acquiring this software on behalf of the
# U.S. government, the Government shall have only "Restricted Rights"
# in the software and related documentation as defined in the Federal
# Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2).  If you
# are acquiring the software on behalf of the Department of Defense,
# the software shall be classified as "Commercial Computer Software"
# and the Government shall have only "Restricted Rights" as defined in
# Clause 252.227-7013 (c) (1) of DFARs.  Notwithstanding the foregoing,
# the authors grant the U.S. Government and others acting in its behalf
# permission to use and distribute the software in accordance with the
# terms specified in this license.

package require Tcl 8.6

package require oo::util
# The mixin of "oo::class.Delegate", interacts badly with meta-classes that
# have constructor arguments. So we eliminate the oo::class mixins here. This
# will mean that you can't define class methods.
::oo::define oo::class self mixin
package require struct::set
package require struct::list
package require textutil::adjust

proc ::oo::Helpers::linkTo {childns args} {   # <1>
    set childns [string trim $childns :]    ; # <2>
    namespace eval $childns {}              ; # <3>
    set ns [uplevel 1 {namespace current}]
    foreach link $args {
	if {[llength $link] == 2} {
	    lassign $link src dst
	} else {
	    lassign $link src
	    set dst $src
	}
	interp alias {} ${ns}::${childns}::$src {} ${ns}::my $dst ; # <4>
    }
    return
}

namespace eval ::stsatcl {
    namespace export STSAClass
    namespace export traceControl
    namespace export decodeAllTraces
    namespace export decodeClassTraces
    namespace export decodeTargetTraces
    namespace export formatTraces
    namespace export diagAllTraces
    namespace export diagClassTraces
    namespace ensemble create

    variable version 1.0.3

    variable errFormats
    set errFormats [dict create {*}{
        BADATTRIBUTENAME        {invalid attribute name, "%s"}
        DUPATTRIBUTENAME        {duplicate attribute name, "%s"}
        DUPREFERENCE        {linkage, "%s", already exists}
        BADREFSPEC          {bad reference spec, "%s"}
        PARTITION       {partition, "%s", must have at least two subclasses}
        RESERVED_STATE      {states may not be named by the reserved name, "%s"}
        DUPLICATE_STATE     {duplicate state, "%s"}
        TRANS_SRC           {a transition cannot originate from the "%s" pseudo-state}
        TRANS_DST           {the initial pseudo-state, "@", cannot be the\
                             target of a transition}
        DUPLICATE_TRANS     {duplicate transition, "%s - %s"}
        BAD_DEFAULT_TRANS       {bad default transition name, "%s": must be one of\
                                 "IG" or "CH"}
        BAD_INIT_STATE      {initial state, "%s", cannot be "IG", "CH", "@" or empty}
        BAD_TERM_STATE  {terminal state, "%s", cannot be "IG", "CH", "@" or empty}
        UNKNOWN_SRC_STATE       {unknown source state in transition, "%s - %s -> %s"}
        UNKNOWN_DST_STATE       {unknown target state in transition, "%s - %s -> %s"}
        ISOLATED        {state model has isolated state(s): "%s"}
        UNKNOWN_INIT_STATE      {unknown initial state, "%s"}
        UNKNOWN_TERM_STATE      {unknown terminal states, "%s"}
        COMMON_EVENTS   {polymorphic events and ordinary events cannot have\
                         the same name, "%s"}
        BAD_POLY_EVENTS     {polymorphic events, "%s", are defined,\
                             but there are no defined partition linkages}
        UNKNOWN_ATTRIBUTE        {unknown attribute, "%s"}
        UNKNOWN_STATE   {unknown state, "%s", should be one of, "%s"}
        OVERLINK        {attempt to over-link: %s is currently linked to %s across %s,\
                         requested link to %s}
        UNKNOWN_LINKTYPE {unknown linkage type, "%s"}
        NOT_LINKED       {object, "%s", is not linked to "%s"}
        UNCOND          {reference, "%s", is unconditional, yet no instances were found}
        NOSUBCLASS      {navigation of "%s" from supertype to subtype\
                         requires the destination subtype class}
        NOT_SUBCLASS    {subclass, "%s", is not a subclass of partition "%s"}
        NOT_PARTITION    {linkage "%s" is not a partition}
        INVALIDTIME    {invalid signal delay time, "%ld"}
        CH_TRANSITION   {can't happen transition: %s - %s -> %s ==> %s -> CH}
        BAD_TRACEOP     {unknown trace operation, "%s"}
        NO_SAVEFILE     {no save file name provided}
        BAD_TRACETYPE   {unknown trace type, "%s"}
        UNKNOWN_INFO        {unknown information topic, "%s"}
        NODOT        {cannot find \"dot\" executable}
        UNKNOWN_LINKAGE     {unknown linkage, "%s"}
        NOT_AN_INSTANCE {instance, "%s", is not an instance of class, "%s"}
        NOT_A_SUBCLASS {instance, "%s", is not an instance of any subclasses, "%s"}
        CANNOT_RESOLVE_CLASS    {cannot resolve, "%s", to a class}
        UNKNOWN_EVENT {unknown event, "%s"}
    }]
    variable traceInitialized false
    variable traceState off
}

proc ::stsatcl::DeclError {errcode args} {
    variable errFormats
    set errmsg [format [dict get $errFormats $errcode] {*}$args]
    tailcall throw [list STSACLASS $errcode {*}$args $errmsg] $errmsg
}
::oo::class create ::stsatcl::STSAClass {
    superclass ::oo::class      ; # <1>
    unexport new                ; # <2>
    constructor {{config {}}} {
        ::oo::objdefine [self] export new ; # <1>
        link\
            {attribute Attribute}\
            {reference Reference}\
            {partition Partition}\
            {instop InstOp}\
            {classop ClassOp}\
            {constructor Constructor}\
            {destructor Destructor}\
            {polymorphic Polymorphic}\
            {statemodel Statemodel}
        my variable attrInfo
        set attrInfo [dict create]
        my variable linkInfo
        set linkInfo [dict create]
        my variable partitions
        set partitions [list]
        linkTo smdsl\
            {state State}\
            {transition Transition}\
            {defaultTrans DefaultTrans}\
            {initialState InitialState}\
            {terminal Terminal}
        my variable polyEvents
        set polyEvents [list]
        my variable cscript
        set cscript {}
        my variable dscript
        set dscript {}
        my variable states
        set states [list]
        my variable events
        set events [list]
        my variable transitions
        set transitions [dict create]
        my variable defaulttrans
        set defaulttrans CH
        my variable initialstate
        set initialstate {}
        my variable terminals
        set terminals [list]
        my eval $config
        if {[dict size $attrInfo] != 0} {
            ::oo::define [self] {
                method readAttributes {args} {
                    set nargs [llength $args]
                    if {$nargs == 1} {
                        set attrName [lindex $args 0] ; # <1>
                        my variable $attrName
                        try {
                            return [set $attrName]
                        } on error {} {
                            tailcall ::stsatcl::DeclError UNKNOWN_ATTRIBUTE $attrName
                        }
                    }
                
                    set attrNames $args ; # <2>
                    if {$nargs == 0} {
                        classvariable attrInfo
                        set attrNames [dict keys $attrInfo]
                    }
                    my variable {*}$attrNames ; # <3>
                
                    set result [dict create]
                    foreach attrName $attrNames {
                        try {
                            dict set result $attrName [set $attrName]
                        } on error {} {
                            tailcall ::stsatcl::DeclError UNKNOWN_ATTRIBUTE $attrName
                        }
                    }
                    return $result
                }
                method updateAttributes {args} {
                    classvariable attrInfo
                
                    dict for {attribute value} $args {
                        if {[dict exists $attrInfo $attribute]} {
                            my variable $attribute
                            set $attribute $value
                        } else {
                            tailcall ::stsatcl::DeclError UNKNOWN_ATTRIBUTE $attribute
                        }
                    }
                    return
                }
            }
        }
        if {[dict size $linkInfo] != 0} {
            ::oo::define [self] {
                method link {rname target} {
                    set target [my ResolveObj $target] ; # <1>
                    my CheckLinkName $rname
                    my CheckReferenceObj $rname $target
                
                    classvariable linkInfo
                    my variable $rname
                    set multiple [expr {[dict get $linkInfo $rname type] eq "reference" ?\
                            [dict get $linkInfo $rname mult] : 0}] ; # <2>
                
                    if {$multiple} {
                        ::struct::set include $rname $target ; # <3>
                    } else {
                        if {[set $rname] eq {}} {
                            set $rname $target
                        } else {
                            tailcall ::stsatcl::DeclError OVERLINK [self] [set $rname]\
                                   $rname $target ; # <4>
                        }
                    }
                    return $target
                }
                method unlink {rname target} {
                    set target [my ResolveObj $target]
                    my CheckLinkName $rname
                    my CheckReferenceObj $rname $target
                
                    classvariable linkInfo
                    my variable $rname
                    switch -exact -- [dict get $linkInfo $rname type] {
                        reference {
                            set multiple [dict get $linkInfo $rname mult]
                            set match [::struct::set contains [set $rname] $target]
                        }
                        partition {
                            set multiple 0
                            set match [expr {$target eq [set $rname]}]
                        }
                        default {
                            tailcall ::stsatcl::DeclError UNKNOWN_LINKTYPE\
                                    [dict get $linkInfo $rname type]
                        }
                    }
                    if {$match} {
                        if {$multiple} {
                            ::struct::set exclude $rname $target
                        } else {
                            set $rname {}
                        }
                    } else {
                        tailcall ::stsatcl::DeclError NOT_LINKED $target $rname
                    }
                
                    return
                }
                method -> {rname args} {
                    classvariable linkInfo
                    my CheckLinkName $rname
                
                    my variable $rname
                    set relobjs [set $rname]
                
                    switch -exact -- [dict get $linkInfo $rname type] {
                        reference {
                            if {![dict get $linkInfo $rname cond] && [llength $relobjs] == 0} {
                                tailcall ::stsatcl::DeclError UNCOND $rname
                            }
                        }
                        partition {
                            if {$relobjs eq {}} {
                                tailcall ::stsatcl::DeclError UNCOND $rname
                            }
                            if {[llength $args] < 1} { # <1>
                                tailcall ::stsatcl::DeclError NOSUBCLASS $rname
                            }
                
                            set subclass [lindex $args 0]
                            set args [lrange $args 1 end]
                
                            set subclass [my ResolveClass $subclass] ; # <2>
                            if {$subclass ni [dict get $linkInfo $rname subclasses]} {
                                tailcall ::stsatcl::DeclError NOT_SUBCLASS $subclass $rname
                            }
                            if {[llength [info class instances $subclass $relobjs]] == 0} {
                                set relobjs [list]
                            }
                        }
                        default {
                            tailcall ::stsatcl::DeclError UNKNOWN_LINKTYPE\
                                    [dict get $linkInfo $rname type]
                        }
                    }
                
                    if {[llength $args] != 0} {
                        set related [list]
                        foreach robj $relobjs {
                            ::struct::set add related [$robj -> {*}$args] ; # <3>
                        }
                    } else {
                        set related $relobjs
                    }
                
                    return [expr {[llength $related] < 2 ? [lindex $related 0] : $related}] ; #<4>
                }
                export ->
                method migrate {rname subclass args} {
                    set subclass [my ResolveObj $subclass]
                    my CheckLinkName $rname
                
                    classvariable linkInfo
                    if {[dict get $linkInfo $rname type] ne "partition"} {
                        tailcall ::stsatcl::DeclError NOT_PARTITION $rname
                    }
                    if {$subclass ni [dict get $linkInfo $rname subclasses]} {
                        tailcall ::stsatcl::DeclError NOT_SUBCLASS $subclass $rname
                    }
                
                    my variable $rname
                    set subinst [set $rname]
                    if {$subinst eq {}} {
                        tailcall ::stsatcl::DeclError UNCOND $rname
                    }
                    $subinst destroy
                
                    set $rname [$subclass new {*}$args]
                }
            }
        }
        if {[llength $states] != 0 || [llength $polyEvents] != 0} {
            set outstates [list]
            set instates [list]
            dict for {src trans} $transitions {
                dict for {event dst} $trans {
                    if {$src ni $states} { # <1>
                        tailcall ::stsatcl::DeclError UNKNOWN_SRC_STATE $src $event $dst
                    }
                    ::struct::set include outstates $src
                    if {$dst ni {IG CH}} { # <2>
                        if {$dst ni $states} {
                            tailcall ::stsatcl::DeclError UNKNOWN_DST_STATE $src $event $dst
                        } else {
                            ::struct::set include instates $dst
                        }
                    }
                }
            }
            set noincoming [::struct::set difference $states $instates]
            set nooutgoing [::struct::set difference $states $outstates]
            set isostates [::struct::set intersect $noincoming $nooutgoing]
            if {![::struct::set empty $isostates]} {
                tailcall ::stsatcl::DeclError ISOLATED $isostates
            }
            foreach s $states {
                foreach e $events {
                    set id [list $s $e]
                    if {![dict exists $transitions $s $e]} {
                        dict set transitions $s $e $defaulttrans
                    }
                }
            }
            if {$initialstate eq {}} {
                set initialstate [lindex $states 0]
            } elseif {$initialstate ni $states} {
                tailcall ::stsatcl::DeclError UNKNOWN_INIT_STATE $initialstate
            }
            if {![::struct::set subsetof $terminals $states]} {
                set unknown [::struct::set difference $terminals $states]
                tailcall ::stsatcl::DeclError UNKNOWN_TERM_STATE $unknown
            }
            if {"@" in $states} {
                ::oo::objdefine [self] method signal {event args} {
                    try {
                        set src [lindex [uplevel 1 {self caller}] 1]
                    } on error {} {
                        set src {}
                    }
            
                    set inst [my newin @]
                    ::stsatcl::TraceCreation $src $event $inst
                    $inst signal $event {*}$args
                    return $inst
                }
            }
            ::oo::objdefine [self] {
                method createin {name initialstate args} {
                    my variable states
                    if {$initialstate in $states} { # <1>
                        if {[string range $name 0 1] ne "::"} {
                            set ns [string trimright [uplevel 1 namespace current] :]
                            set name ${ns}::${name}
                        }
                        set inst [my create $name {*}$args]
                        set [info object namespace $inst]::__currentstate__ $initialstate
                    } else {
                        tailcall ::stsatcl::DeclError UNKNOWN_STATE $initialstate $states
                    }
                
                    return $inst
                }
                method newin {initialstate args} {
                    my variable states
                    if {$initialstate in $states} {
                        set inst [my new {*}$args]  ; # <1>
                        set [info object namespace $inst]::__currentstate__ $initialstate
                    } else {
                        tailcall ::stsatcl::DeclError UNKNOWN_STATE $initialstate $states
                    }
                
                    return $inst
                }
            }
            ::oo::define [self] {
                destructor {
                    my variable __currentstate__
                    if {[info exists __currentstate__]} {
                        my variable __signals__ ; # <1>
                        foreach {sigid timerid} [array get __signals__] {
                            after cancel $timerid
                        }
                        my variable __delayedSignals__
                        foreach {sigid sigdetails} [array get __delayedSignals__] {
                            after cancel [dict get $sigdetails timerid]
                        }
                    }
                    classvariable dscript ; # <1>
                    my eval $dscript
                }
                method signal {event args} {
                    set src [my EventSource]
                    classvariable polyEvents
                    if {$event in $polyEvents} {
                        my ForwardPolyEvent signal $src $event $args
                    } else {
                        my ValidateEvent $event
                        set eventInfo [dict create\
                            src $src\
                            event $event\
                            params $args\
                        ]
                        my variable __event_queue__
                        # Self directed events are queued to the front.  However, we handle the
                        # case where a state activity may signal multiple self-directed events.
                        # In that, admittedly unusual case, we want to preserve the order of
                        # the signaled events.
                        if {$src eq [self]} {
                            for {set nsindex 0} {$nsindex < [llength $__event_queue__]}\
                                    {incr nsindex} { # <1>
                                set cmpevent [lindex $__event_queue__ $nsindex]
                                if {[dict get $cmpevent src] ne [self]} {
                                    break ; # <2>
                                }
                            }
                            set __event_queue__ [linsert $__event_queue__ $nsindex $eventInfo]
                        } else {
                            lappend __event_queue__ $eventInfo ; # <3>
                        }
                        my variable __event_counter__
                        incr __event_counter__
                        set timerid [::after 0 [mymethod Dispatch $__event_counter__]]
                        my variable __signals__
                        set __signals__($__event_counter__) $timerid
                    }
                }
                method delayedSignal {time event args} {
                    if {!([string is integer -strict $time] && $time >= 0)} {
                        tailcall ::stsatcl::DeclError INVALIDTIME $time
                    }
                    set src [my EventSource]
                    classvariable polyEvents
                    if {$event in $polyEvents} {
                        my ForwardPolyEvent [list delayedSignal $time] $src $event $args
                    } else {
                        # Cancel any existing delayed signal that might have been in place.
                        my CancelDelayedSignal $src $event
                
                        my variable __delayedSignals__
                        set __delayedSignals__($src,$event) [dict create\
                            timerid\
                                [::after $time [mymethod DelayedDispatch $src $event]]\
                            expire [expr {[clock milliseconds] + $time}]\
                            info [dict create\
                                src $src\
                                event $event\
                                params $args\
                            ]
                        ]
                    }
                    return
                }
                method cancel {event} {
                    return [my CancelDelayedSignal [my EventSource] $event]
                }
                method remaining {event} {
                    set src [my EventSource]
                    my variable __delayedSignals__
                    return [expr {[info exists __delayedSignals__($src,$event)] ?\
                            max([dict get $__delayedSignals__($src,$event) expire]\
                                - [clock milliseconds], 0) : 0}] ; # <1>
                }
                method force {state args} {
                    classvariable states
                    if {$state ni $states} {
                        tailcall ::stsatcl::DeclError UNKNOWN_STATE $state $states
                    }
                    my variable __currentstate__
                    set __currentstate__ $state
                    my ${__currentstate__}__STATE__ {*}$args
                    return
                }
                method currentstate {} {
                    my variable __currentstate__
                    return $__currentstate__
                }
                method Receive {eventInfo} {
                    my variable __currentstate__
                    set src [dict get $eventInfo src]
                    set event [dict get $eventInfo event]
                    set params [dict get $eventInfo params]
                
                    classvariable transitions
                    set newState [dict get $transitions $__currentstate__ $event] ; # <1>
                
                    ::stsatcl::TraceTransition $src $event [self] $__currentstate__\
                            $newState $params
                
                    if {$newState eq "CH"} { # <2>
                        tailcall ::stsatcl::DeclError CH_TRANSITION\
                            [list $src] $event [self] $__currentstate__
                    } elseif {$newState ne "IG"} {
                        set __currentstate__ $newState ; # <3>
                        try {
                            my ${__currentstate__}__STATE__ {*}$params ; # <4>
                        } finally {
                            classvariable terminals ; # <5>
                            if {$__currentstate__ in $terminals} {
                                my destroy
                            }
                        }
                    }
                    return
                }
                method Dispatch {eventid} {
                    my variable __signals__
                    array unset __signals__ $eventid
                    my variable __event_queue__
                    if {[llength $__event_queue__] != 0} { # <1>
                        # Pull the event from the front of the queue.
                        set eventInfo [lindex $__event_queue__ 0]
                        set __event_queue__ [lrange $__event_queue__ 1 end]
                        tailcall my Receive $eventInfo
                    }
                }
                method DelayedDispatch {src event} {
                    my variable __delayedSignals__
                    if {[info exists __delayedSignals__($src,$event)]} { # <1>
                        set eventInfo [dict get $__delayedSignals__($src,$event) info]
                        array unset __delayedSignals__ $src,$event
                        tailcall my Receive $eventInfo ; # <2>
                    }
                }
                method CancelDelayedSignal {src event} {
                    my ValidateEvent $event
                    # Check if we have the delayed signal. It might not exist
                    # or have already been dispatched. We return an indication
                    # of whether the signal was indeed canceled.
                    my variable __delayedSignals__
                    if {[info exists __delayedSignals__($src,$event)]} {
                        after cancel [dict get $__delayedSignals__($src,$event) timerid]
                        array unset __delayedSignals__ "$src,$event"
                        set result true
                    } else {
                        set result false
                    }
                    return $result
                }
            }
        } elseif {$dscript ne {}} {
            ::oo::define [self] destructor {
                classvariable dscript
                my eval $dscript
            }
        }
        set commonEvents [::struct::set intersect $polyEvents $events]
        if {![::struct::set empty $commonEvents]} {
            tailcall ::stsatcl::DeclError COMMON_EVENTS $commonEvents
        }
        if {[llength $polyEvents] != 0 && [llength $partitions] == 0} {
            tailcall ::stsatcl::DeclError BAD_POLY_EVENTS $polyEvents
        }
        ::oo::define [self] {
            method selectRelatedWhere {rlist varname expr} {
                tailcall ::struct::list filterfor $varname [my -> {*}$rlist] $expr
            }
            method selectOneRelatedWhere {rlist varname expr} {
                tailcall lindex [uplevel 1\
                    [list ::struct::list filterfor $varname [my -> {*}$rlist] $expr]] 0 ; # <1>
            }
            method mapRelatedInstances {rlist varname script} {
                uplevel 1 [list ::lmap $varname [my -> {*}$rlist] $script]
            }
            method CheckLinkName {rname} {
                classvariable linkInfo
                if {![dict exists $linkInfo $rname]} {
                    tailcall ::stsatcl::DeclError UNKNOWN_LINKAGE $rname
                }
            }
            method CheckReferenceObj {rname obj} {
                classvariable linkInfo
            
                set objclass [info object class $obj]
                switch -exact -- [dict get $linkInfo $rname type] {
                    reference {
                        set destclass [dict get $linkInfo $rname dest]
                        if {!($objclass eq $destclass ||\
                                $destclass in [info class superclasses $objclass])} {
                            tailcall ::stsatcl::DeclError NOT_AN_INSTANCE\
                                $obj [dict get $linkInfo $rname dest]
                        }
                    }
                    partition {
                        set subclasses [dict get $linkInfo $rname subclasses]
                        foreach subclass $subclasses {
                            if {$objclass eq $subclass ||\
                                $subclass in [info class superclasses $objclass]} {
                                return
                            }
                        }
                        tailcall ::stsatcl::DeclError NOT_A_SUBCLASS\
                            $obj [join $subclasses {, }]
                    }
                    default {
                        tailcall ::stsatcl::DeclError UNKNOWN_LINKTYPE\
                                [dict get $linkInfo $rname type]
                    }
                }
            }
            method ResolveObj {obj} {
                if {[string range $obj 0 1] ne "::"} {
                    set obj\
                        [string trimright [uplevel 2 namespace current] :]::$obj
                }
                return $obj
            }
            method ResolveClass {class} {
                if {[string range $class 0 1] ne "::"} {
                    set myclass [info object class [self]]
                    set class [namespace qualifiers $myclass]::$class
                    if {[llength [info commands $class]] == 0 ||
                            ![info object isa class $class]} {
                        tailcall ::stsatcl::DeclError CANNOT_RESOLVE_CLASS $class
                    }
                }
                return $class
            }
            method ValidateEvent {event} {
                classvariable events
                if {$event ni $events} {
                    tailcall ::stsatcl::DeclError UNKNOWN_EVENT $event
                }
            }
            method EventSource {} {
                try {
                    set src [lindex [uplevel 1 {self caller}] 1] ; # <1>
                } on error {} {
                    set src {}
                }
                return $src
            }
            method ForwardPolyEvent {type src event arglist} {
                classvariable partitions
                foreach partition $partitions { # <1>
                    my variable $partition
                    set target [set $partition] ; # <2>
                    if {$target eq {}} {
                        tailcall ::stsatcl::DeclError UNCOND $partition
                    }
                    ::stsatcl::TracePolymorphic $src $event $target [self] $partition
                    $target {*}$type $event {*}$arglist ; # <3>
                }
            }
        }
        ::oo::objdefine [self] {
            method selectWhere {varname expr} {
                tailcall ::struct::list filterfor $varname [info class instances [self]]\
                        $expr ; # <1>
            }
            method selectOneWhere {varname expr} {
                tailcall lindex [uplevel 1 [list ::struct::list filterfor $varname\
                    [info class instances [self]] $expr]] 0 ; # <1>
            }
            method mapInstances {varname script} {
                uplevel 1 [list ::lmap $varname [info class instances [self]] $script]
            }
        }
        ::oo::define [self] constructor {args} {
            classvariable attrInfo  ; # <1>
            
            if {[dict size $attrInfo] != 0} { # <2>
                dict for {attrName defValue} [dict merge $attrInfo $args] {
                    if {[dict exists $attrInfo $attrName]} { # <3>
                        my variable $attrName
                        set $attrName $defValue
                    } else {
                        tailcall ::stsatcl::DeclError UNKNOWN_ATTRIBUTE $attrName
                    }
                }
            }
            classvariable linkInfo
            
            foreach linkName [dict keys $linkInfo] {
                my variable $linkName
                set $linkName {}
            }
            classvariable states
            if {[llength $states] != 0} {
                my variable __currentstate__
                # Set the initial state to the default
                classvariable initialstate
                set __currentstate__ $initialstate
            
                my variable __event_queue__
                set __event_queue__ [list] ; # <1>
                # We also need to keep track of the timer ID's for the non-delayed signals.
                my variable __signals__
                array set __signals__ {}
                # Delayed signals require some additional bookkeeping.
                my variable __delayedSignals__
                array set __delayedSignals__ {}
            }
        
            classvariable cscript ; # <1>
            my eval $cscript
        }
        ::oo::objdefine [self] {
            method info {topic} {
                switch -exact -- $topic {
                    attributes {
                        my variable attrInfo
                        return [dict keys $attrInfo]
                    }
                    links {
                        my variable linkInfo
                        return [dict keys $linkInfo]
                    }
                    states {
                        my variable states
                        return $states
                    }
                    events {
                        my variable events
                        return $events
                    }
                    transitions {
                        my variable transitions
                        set result [list]
                        dict for {src trans} $transitions {
                            dict for {evt dst} $trans {
                                lappend result [list $src $evt $dst]
                            }
                        }
                        return $result
                    }
                    initialstate {
                        my variable initialstate
                        return $initialstate
                    }
                    defaulttrans {
                        my variable defaulttrans
                        return $defaulttrans
                    }
                    terminals {
                        my variable terminals
                        return $terminals
                    }
                    polyevents {
                        my variable polyEvents
                        return $polyEvents
                    }
                    default {
                        tailcall ::stsatcl::DeclError UNKNOWN_INFO $topic
                    }
                }
            }
            method dot {} {
                set result {}
                append result "digraph [namespace tail [self]] \{" \n
                append result "    node\[shape=\"box\"]" \n
            
                my variable states
                foreach state $states {
                    if {$state eq "@"} { # <1>
                        append result "    \"@\"\["\
                            "shape=\"point\""\
                            ",label=\"\""\
                            "\]\n" ; # <2>
                    } else {
                        lassign [info class definition [self] ${state}__STATE__]\
                                arguments body ; # <3>
                        set code "$state \{$arguments\} \{"
                        append code\
                                [textutil::adjust::indent [textutil::adjust::undent $body]\
                                {    }] ; # <4>
                        append code "\n\}"
                        set labelCode {}
                        set escapemap [list \\ \\\\ \" \\\"] ; # <5>
                        foreach line [split $code \n] {
                            append labelCode\
                                [string map $escapemap $line]\
                                "\\l"
                        }
                        set stProps "label=\"$labelCode\""
            
                        my variable initialstate
                        if {$state eq $initialstate} {
                            append stProps ",style=\"bold\""
                        }
                        append result "    \"$state\"\[$stProps]" \n
                    }
                }
            
                my variable transitions
                dict for {currstate trans} $transitions {
                    dict for {event dststate} $trans {
                        if {!($dststate eq "IG" || $dststate eq "CH")} {
                            append result "    \"$currstate\" -> \"$dststate\"\
                                    \[label=\"$event\"]" \n
                        }
                    }
                }
            
                append result "\}"
            
                return $result
            }
            method dotfile {filename} {
                set chan [open $filename w]
                try {
                    chan puts $chan [my dot]
                } finally {
                    chan close $chan
                }
                return
            }
            method draw {{dotopts {-Gcenter=1 -Gratio=auto -Gsize=7.5,10 -Tps -o%F.ps}}} {
                set dotexec [auto_execok dot]
                if {$dotexec eq {}} {
                    tailcall ::stsatcl::DeclError NODOT
                }
                set dotopts [string map [list %F [namespace tail [self]]] $dotopts] ; #<1>
                set chan [open "| $dotexec $dotopts" w]
                try {
                    chan puts $chan [my dot]
                } finally {
                    chan close $chan
                }
                return
            }
        }
    }
    method Attribute {args} {
        my variable attrInfo
    
        foreach attr $args {
            lassign $attr name dfltvalue
            if {$name eq {}} {
                tailcall ::stsatcl::DeclError BADATTRIBUTENAME $name
            }
            if {[dict exists $attrInfo $name]} {
                tailcall ::stsatcl::DeclError DUPATTRIBUTENAME $name
            } else {
                dict set attrInfo $name $dfltvalue
            }
        }
    }
    method Qualify {cmdname {level 4}} {
        return [expr {[string range $cmdname 0 1] ne "::" ?\
            "[string trimright [uplevel $level namespace current] :]::$cmdname" :\
            $cmdname}] ; # <1>
    }
    method Reference {rname spec dstclass} {
        my variable linkInfo
        if {[dict exists $linkInfo $rname]} {
            tailcall ::stsatcl::DeclError DUPREFERENCE $rname
        }
        set dstclass [my Qualify $dstclass]
    
        if {![regexp -- {\A-(>{1,2})(c?)\Z} $spec match mult cond]} { # <1>
            tailcall ::stsatcl::DeclError BADREFSPEC $spec
        }
    
        dict set linkInfo $rname [dict create\
            type reference\
            dest $dstclass\
            mult [string equal $mult ">>"]\
            cond [string equal $cond "c"]\
        ]
    }
    method Partition {rname args} {
        my variable linkInfo
        if {[dict exists $linkInfo $rname]} {
            tailcall ::stsatcl::DeclError DUPREFERENCE $rname
        }
        if {[llength $args] < 2} { # <1>
            tailcall ::stsatcl::DeclError PARTITION $rname
        }
    
        set subs [list]
        foreach sub $args {
            ::struct::set include subs [my Qualify $sub]
        }
        dict set linkInfo $rname [dict create\
            type partition\
            subclasses $subs\
        ]
        my variable partitions
        lappend partitions $rname
    }
    method Statemodel {script} {
        namespace eval [namespace current]::smdsl $script
    }
    method Polymorphic {args} {
        my variable polyEvents
        ::struct::set add polyEvents $args
    }
    method InstOp {name arglist body} {
        ::oo::define [self] method $name $arglist $body ; # <1>
        ::oo::define [self] export $name                ; # <2>
    }
    method ClassOp {name arglist body} {
        ::oo::objdefine [self] method $name $arglist $body  ; # <1>
        ::oo::objdefine [self] export $name                 ; # <2>
    }
    method Constructor {body} {
        my variable cscript
        set cscript $body
    }
    method Destructor {body} {
        my variable dscript
        set dscript $body
    }
    method State {name argList body} {
        my variable states
        if {$name in {IG CH @}} {
            tailcall ::stsatcl::DeclError RESERVED_STATE $name
        } elseif {$name in $states} {
            tailcall ::stsatcl::DeclError DUPLICATE_STATE $name
        } else {
            lappend states $name  ; # <1>
            ::oo::define [self] method ${name}__STATE__ $argList $body ; # <2>
            ::oo::define [self] unexport ${name}__STATE__              ; # <3>
        }
    }
    method Transition {current - event -> target} {
        if {$current in {IG CH}} {
            tailcall ::stsatcl::DeclError TRANS_SRC $current
        } elseif {$current eq "@"} { # <1>
            my variable states
            ::struct::set include states $current
        }
    
        if {$target eq "@"} {
            tailcall ::stsatcl::DeclError TRANS_DST
        }
        my variable events
        ::struct::set include events $event ; # <2>
    
        my variable transitions
        if {[dict exists $transitions $current $event]} {
            tailcall ::stsatcl::DeclError DUPLICATE_TRANS $current $event
        } else {
            dict set transitions $current $event $target
        }
    }
    method DefaultTrans {trans} {
        if {$trans in {IG CH}} {
            my variable defaulttrans
            set defaulttrans $trans
        } else {
            tailcall ::stsatcl::DeclError BAD_DEFAULT_TRANS $trans
        }
    }
    method InitialState {state} {
        if {$state in {IG CH @ {}}} {
            tailcall ::stsatcl::DeclError BAD_INIT_STATE $state
        }
        my variable initialstate
        set initialstate $state
    }
    method Terminal {args} {
        foreach state $args {
            if {$state in {IG CH @ {}}} {
                tailcall ::stsatcl::DeclError BAD_TERM_STATE $state
            }
        }
        my variable terminals
        ::struct::set add terminals $args
    }
}

proc ::stsatcl::traceControl {op args} {
    variable traceInitialized       ; # <1>
    if {!$traceInitialized} {
        set traceInitialized true
        package require ral
        package require ralutil
        package require logger
        variable traceLogCmd [::logger::init stsatcl]
        namespace import ::ral::*
        namespace import ::ralutil::*
        
        relvar create Trace {
            Trace_Id    int
            Timestamp   bignum
            Source      string
            Event       string
            Target      string
            Class       string
        } Trace_Id
        
        relvar create Creation {
            Trace_Id    int
        } Trace_Id
        
        relvar create Polymorphic {
            Trace_Id    int
            SuperClass  string
            Linkage     string
        } Trace_Id
        
        relvar create Transition {
            Trace_Id    int
            CurrState   string
            NewState    string
            Params      list
        } Trace_Id
        
        relvar partition R1 Trace Trace_Id\
            Creation Trace_Id\
            Polymorphic Trace_Id\
            Transition Trace_Id
        variable traceNumber 0
        variable traceLogState off
        variable traceLogLevel info
    }
    switch -exact -- $op {
        on {
            variable traceState on
        }
        off {
            variable traceState off
            set traceState off
        }
        status {
            variable traceState
            return $traceState
        }
        clear {
            relvar eval {
                foreach rvar {Trace Creation Polymorphic Transition} {
                    relvar set $rvar [relation emptyof [relvar set $rvar]]
                }
            }
            variable traceNumber 0
        }
        logon {
            variable traceLogState on
        }
        logoff {
            variable traceLogState off
        }
        loglevel {
            variable traceLogLevel
            if {[llength $args] != 0} {
                set traceLogLevel [lindex $args 0]
            }
            return $traceLogLevel
        }
        save {
            if {[llength $args] == 0} {
                DeclError NO_SAVEFILE
            }
            storeToSQLite [lindex $args 0] [relvar names [namespace current]::*]
        }
        default {
            DeclError BAD_TRACEOP $op
        }
    }
}

proc ::stsatcl::TraceCreation {source event target} {
    variable traceState
    if {$traceState} {
        relvar eval {
            set trace [NewTrace $source $event $target]
            relvar insert Creation [list\
                Trace_Id    [relation extract $trace Trace_Id]\
            ]
        }
        LogTrace $trace
    }
}
proc ::stsatcl::TracePolymorphic {source event target super link} {
    variable traceState
    if {$traceState} {
        relvar eval {
            set trace [NewTrace $source $event $target]
            relvar insert Polymorphic [list\
                Trace_Id    [relation extract $trace Trace_Id]\
                SuperClass  $super\
                Linkage     $link\
            ]
        }
        LogTrace $trace
    }
}
proc ::stsatcl::TraceTransition {source event target curr new params} {
    variable traceState
    if {$traceState} {
        relvar eval {
            set trace [NewTrace $source $event $target]
            relvar insert Transition [list\
                Trace_Id    [relation extract $trace Trace_Id]\
                CurrState   $curr\
                NewState    $new\
                Params      $params\
            ]
        }
        LogTrace $trace
    }
}
proc ::stsatcl::NewTrace {src event target} {
    variable traceNumber
    return [relvar insert Trace [list\
        Trace_Id    [incr traceNumber]\
        Timestamp   [clock microseconds]\
        Source      $src\
        Event       $event\
        Target      $target\
        Class       [info object class $target]\
    ]]
}
proc ::stsatcl::LogTrace {trace} {
    variable traceLogState
    if {$traceLogState} {
        set rec [FormatTraceRec [lindex [TracesToRecords $trace] 0]] ; # <1>

        variable traceLogCmd
        variable traceLogLevel
        ${traceLogCmd}::${traceLogLevel} $rec
    }
}
proc ::stsatcl::TracesToRecords {traces} {
    foreach rvname {Creation Polymorphic Transition} { # <1>
        set traces [rvajoin $traces [relvar set $rvname] $rvname]
    }

    set result [list]
    relation foreach trace $traces -ascending Trace_Id { # <2>
        relation assign $trace
        set labeled [dict create\
            id      $Trace_Id\
            time    $Timestamp\
            source  $Source\
            event   $Event\
            target  $Target\
            class   $Class\
        ] ; # <3>
        if {[relation isnotempty $Transition]} { # <4>
            relation assign $Transition
            dict set labeled type transition
            dict set labeled current $CurrState
            dict set labeled new $NewState
            dict set labeled params $Params
        } elseif {[relation isnotempty $Polymorphic]} {
            relation assign $Polymorphic
            dict set labeled type polymorphic
            dict set labeled super $SuperClass
            dict set labeled link $Linkage
        } elseif {[relation isnotempty $Creation]} {
            dict set labeled type creation
        }

        lappend result $labeled
    }
    return $result
}
proc ::stsatcl::decodeAllTraces {} {
    tailcall TracesToRecords [relvar set Trace]
}

proc ::stsatcl::decodeClassTraces {args} {
    tailcall TracesToRecords [pipe {
        relvar set Trace |
        relation restrictwith ~ {$Class in $args}
    }]
}

proc ::stsatcl::decodeTargetTraces {args} {
    tailcall TracesToRecords [pipe {
        relvar set Trace |
        relation restrictwith ~ {$Target in $args}
    }]
}

proc ::stsatcl::formatTraces {tracerecs} {
    if {[llength $tracerecs] == 0} {
        return {}
    }
    set prevtime [dict get [lindex $tracerecs 0] time]
    foreach rec $tracerecs {
        dict with rec {
            append result "[FormatTimestamp $time]: "
            append result "[FormatTimeAsSec [expr {$time - $prevtime}]]: "
            set prevtime $time
            append result [FormatTraceRec $rec] \n
        }
    }
    return [string trimright $result]
}

proc ::stsatcl::FormatTraceRec {rec} {
    dict with rec {
        switch -exact -- $type {
            transition {
                append result\
                    "Transition: "\
                    "[list $source] - $event \{$params\} -> $target ==> "\
                    "$current -> $new"
            }
            polymorphic {
                append result\
                    "Polymorphic : "\
                    "[list $source] - $event -> $super ==> "\
                    "$link -> $target"
            }
            creation {
                append result\
                    "Creation: "\
                    "[list $source] - $event -> $class ==> $target"
            }
            default {
                DeclError BAD_TRACETYPE $type
            }
        }
    }
    return $result
}
proc ::stsatcl::FormatTimestamp {time} {
    set sec [clock format [expr {$time / 1000000}] -format %T] ; # <1>
    set time [expr {$time % 1000000}]
    set msec [expr {$time / 1000}]
    set usec [expr {$time % 1000}]

    return [format %s.%03ld.%03ld $sec $msec $usec]
}
proc ::stsatcl::FormatTimeAsSec {time} {
    set sec [expr {$time / 1000000}]
    set time [expr {$time % 1000000}]
    set msec [expr {$time / 1000}]
    set usec [expr {$time % 1000}]

    return [format %3ld.%03ld.%03ld $sec $msec $usec]
}
proc ::stsatcl::diagtraces {traces args} {
    set result {}
    append result "seqdiag \{\n"
    append result "    activation = none;\n"
    foreach {option value} $args {
        append result "    $option = $value;\n"
    }

    relation foreach trace $traces -ascending Trace_Id {
        relation assign $trace
        if {$Source eq {}} {
            set Source EXTERNAL
        } else {
            set Source [namespace tail $Source]
        }
        set Target [namespace tail $Target]
        append result "    $Source ->> $Target \[label=\"$Event\"\];\n"
    }

    append result "\}\n"

    return $result
}
proc ::stsatcl::diagAllTraces {filename args} {
    set chan [open $filename w]
    try {
        chan puts $chan [diagtraces [relvar set Trace] {*}$args]
    } finally {
        chan close $chan
    }
    return
}

proc ::stsatcl::diagClassTraces {filename classes args} {
    set chan [open $filename w]
    try {
        set traces [pipe {
            relvar set Trace >
            relation restrictwith ~\
                {$Class in $classes || [namespace tail $Class] in $classes}
        }] {} >~
        chan puts $chan [diagtraces $traces {*}$args]
    } finally {
        chan close $chan
    }
    return
}


package provide stsatcl $::stsatcl::version
