# created by mkmodule: version 1.5
# on Sun Apr 02 16:33:41 PDT 2023
set __loadScript__ {{offset size} {
    set schan [open [info script] r]
    try {
        chan seek $schan $offset start
        uplevel 1 [chan read $schan $size]
    } finally {
        chan close $schan
    }
}}
::apply $__loadScript__ 960 21905
catch {unset __loadScript__}
catch {unset __loadBinary__}
catch {unset __loadedBinary__}
return
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                               
# DO NOT EDIT THIS FILE!
# THIS FILE IS AUTOMATICALLY GENERATED FROM A LITERATE PROGRAM SOURCE FILE.
#  This software is copyrighted 2020 - 2023 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.
# ++
#  Project:
#    mrtools
# 
#  Module:
#    miccautil source code
# --

package require logger
package require logger::utils
package require logger::appender
package require ral
package require ralutil
package require struct::graph 2
package require lambda

namespace eval ::miccautil {
    namespace export model
    namespace export dfs
    namespace export spanningTree
    namespace export graphToDot
    namespace ensemble create

    set logger [::logger::init miccautil]
    set appenderType [expr {[dict exist [fconfigure stdout] -mode] ?\
            "colorConsole" : "console"}]
    ::logger::utils::applyAppender -appender $appenderType -serviceCmd $logger\
            -appenderArgs {-conversionPattern {\[%c\] \[%p\] '%m'}}
    ::logger::import -all -force -namespace log miccautil

    variable version 1.3
}

::oo::class create ::miccautil::model {
    constructor {savefile} {
        ::logger::import -all -namespace log miccautil
    
        namespace import ::ral::*
        namespace import ::ralutil::*
    
        ral deserializeFromFile $savefile [self namespace]
    
        set domains [pipe {
            relvar set Domain |
            relation project ~ Name |
            relation list ~
        }]
    
        if {[llength $domains] > 1} {
            error "micca save file must contain only one domain:\
                    found, \"[join $domains ,]\""
        }
    
        my variable domain_name
        set domain_name [lindex $domains 0]
    
        my variable recording_state
        set recording_state off
    
        my variable previous_callback
        set previous_callback [list]
    }
    destructor {
        relvar constraint delete {*}[relvar constraint names [self namespace]::*]
        relvar unset {*}[relvar names [self namespace]::*]
    }
    method domainName {} {
        my variable domain_name
    
        return $domain_name
    }
    method classes {} {
        return [pipe {
            relvar set Class |
            relation project ~ Name |
            relation list
        }]
    }
    method attributes {class} {
        return [pipe {
            relvar set Attribute |
            relation restrictwith ~ {$Class eq $class} |
            relation dict ~ Name DataType
        }]
    }
    method states {class} {
        return [pipe {
            relvar set StatePlace |
            relation restrictwith ~ {$Model eq $class} |
            relation project ~ Name |
            relation list
        }]
    }
    method events {class} {
        return [pipe {
            relvar set Event |
            relation restrictwith ~ {$Model eq $class} |
            relation project ~ Event |
            relation list
        }]
    }
    method creationevents {class} {
        # log::debug "\n[relformat [relvar set TransitionPlace] TransitionPlace]"
        return [pipe {
            relvar set TransitionPlace |
            relation restrictwith ~ {$Model eq $class && $State eq "@"} |
            relation project ~ Event |
            relation list
        }]
    }
    method transitions {class_name} {
        set transitions [pipe {
            my GetTransitionCells |
            relation restrictwith ~ {$Model eq $class_name} |
            relation join ~ [relvar set Event] |
            relation eliminate ~ Number |
            rvajoin ~ [relvar set EventSignature] EventSig |
            relation extend ~ p_tup Params {Relation {Name string Position int DataType string}} {
                [relation isempty [tuple extract $p_tup EventSig]] ?\
                    [relation create {Name string Position int DataType string}] :\
                    [relation project\
                        [relation join\
                            [relation semijoin\
                                [relvar restrictone ParameterSignature\
                                    Domain [tuple extract $p_tup Domain]\
                                    PSigID [relation extract [tuple extract $p_tup EventSig] PSigID]]\
                                [relvar set Parameter] -using {Domain Domain PSigID PSigID}]\
                            [relvar set Argument]]\
                        Name Position DataType]} |
            relation eliminate ~ EventSig
        }] ;                                                                # <1>
        #log::debug \n[relformat $transitions transitions]
    
        return $transitions
    }
    method GetTransitionCells {} {
        set state_places [pipe {
            relvar set StatePlace |
            relation eliminate ~ Number |
            relation rename ~ Name State
        }]
        set possible_trans [pipe {
            relvar set TransitioningEvent |
            relation join $state_places ~
        }]
        #log::debug \n[relformat $possible_trans possible_trans]
    
        set trans [relvar set StateTransition]
        #log::debug \n[relformat $trans trans]
        set non_trans [pipe {
            relvar set NonStateTransition |
            relation rename ~ TransRule NewState
        }]
        #log::debug \n[relformat $non_trans non_trans]
    
        set spec_trans [relation union $trans $non_trans]
        #log::debug \n[relformat $spec_trans spec_trans]
    
        set defrule [pipe {
            relvar set StateModel |
            relation project ~ Domain Model DefaultTrans |
            relation rename ~ DefaultTrans NewState
        }]
        # log::debug \n[relformat $defrule defrule]
    
        set non_spec_trans [pipe {
            relation project $spec_trans Domain Model State Event |
            relation minus $possible_trans ~ |
            relation join ~ $defrule |
            relation update ~ ftup {[tuple extract $ftup State] eq "@"}\
                {tuple update $ftup NewState CH}
        }]
        # log::debug \n[relformat $non_spec_trans non_spec_trans]
    
        set trans_records [relation union $spec_trans $non_spec_trans]
        #log::debug \n[relformat $trans_records trans_records]
    
        return $trans_records
    }
    method startTransitionRecording {} {
        my variable recording_state
        if {$recording_state eq "on"} {
            return
        }
    
        if {![relvar exists __Event_Record__]} {                        # <1>
            set trans [pipe {
                my GetTransitionCells |
                relation extend ~ sptup TransCount int 0
            }]
            relvar create __Event_Record__ [relation heading $trans]\
                {Domain Model State Event}
            relvar set __Event_Record__ $trans
        } else {
            relvar update __Event_Record__ ertup true {
                tuple update $ertup TransCount 0
            }
        }
    
        set recording_state on
        return
    }
    method stopTransitionRecording {} {
        my variable recording_state
        set recording_state off
    
        return
    }
    method recordTransition {class currstate event} {
        my variable recording_state
        if {$recording_state eq "off"} {
            error "event transition recording is stopped"
        }
    
        my variable domain_name
        set updated [relvar updateone __Event_Record__ ertup\
                [list Domain $domain_name Model $class State $currstate\
                Event $event] {
            tuple update $ertup TransCount\
                    [expr {[tuple extract $ertup TransCount] + 1}]
        }]
    
        return [relation isnotempty $updated]
    }
    method reportTransitions {pattern} {
        return [pipe {
            relvar set __Event_Record__ |
            relation restrictwith ~ {[string match $pattern $Model]}
        }]
    }
    method startMecateTransitionCount {reinobj} {
        my startTransitionRecording
    
        my variable previous_callback
        set previous_callback [$reinobj traceNotify]
        $reinobj traceNotify [mymethod RecordMecateTransition]
    }
    
    method stopMecateTransitionCount {reinobj} {
        my variable previous_callback
        $reinobj traceNotify $previous_callback
    
        my stopTransitionRecording
    }
    method RecordMecateTransition {trace} {
        my variable previous_callback
        if {[llength $previous_callback] != 0} {
            eval [linsert $previous_callback end $trace]
        }
    
        if {[dict get $trace type] eq "transition"} {
            set target_class [lindex [split [dict get $trace target] .] 0] ; # <1>
            my recordTransition $target_class\
                [dict get $trace currstate] [dict get $trace event]
        }
    
        return
    }
    export RecordMecateTransition
    method defaultAttributeValues {} {
        return [pipe {
            relvar set DefaultValue |
            relation join ~ [relvar set Attribute]\
                    -using {Domain Domain Class Class Attribute Name} |
            relation group ~ Defaults Attribute Value DataType
        }]
    }
    method initialInstancePopulation {} {
        return [pipe {
            relvar set PopulatedComponent |
            relation semijoin ~\
                [relvar set ClassComponent]\
                [relvar set ClassComponentValue]\
                    -using {Domain Domain Class Class Name Component}\
                [relvar set SpecifiedComponentValue] |
            relation join ~ [relvar set ClassInstance] |
            relation rename ~ Component Attribute Number ID |
            relation group ~ Attributes Attribute Value |
            relation group ~ Instances Instance ID Attributes
        }]
    }
    method stateModelGraph {class_name} {
        my variable domain_name
        set gr [::struct::graph]
    
        try {
            $gr set domain $domain_name
            $gr set class $class_name
    
            set smodel [relvar restrictone StateModel\
                    Domain $domain_name Model $class_name]
            if {[relation isempty $smodel]} {
                $gr set initialstate {}
                $gr set defaulttrans {}
                return $gr
            }
    
            $gr set defaulttrans [relation extract $smodel DefaultTrans]
    
            set cr_state [pipe {
                relvar set CreationState |
                relation semijoin $smodel ~ |
                relation extend ~ cstup\
                        Activity string {{}}\
                        IsFinal boolean {false} |
                relation project ~ Name Activity IsFinal
            }]
    
            $gr set initialstate [expr {[relation isnotempty $cr_state] ?\
                    "@" : [relation extract $smodel InitialState]}]
    
            set states [pipe {
                relvar set State |
                relation semijoin $smodel ~ |
                relation project ~ Name Activity IsFinal |
                relation union ~ $cr_state
            }]
            # log::debug \n[relformat $states states]
    
            relation foreach state $states {
                relation assign $state Name Activity IsFinal
                $gr node insert $Name
                $gr node set $Name activity $Activity
                $gr node set $Name final $IsFinal
            }
    
            set finals [relation restrictwith $states {$IsFinal}]
            if {[relation isnotempty $finals]} {
                $gr node insert __x__
                $gr node set __x__ activity {}
                $gr node set __x__ final false
            }
            relation foreach final_state $finals {
                relation assign $final_state Name
                $gr arc insert $Name __x__
            }
    
            set trans [pipe {
                my transitions $class_name |
                relation restrictwith ~ {$NewState ne "IG" && $NewState ne "CH"} |
                relation eliminate ~ Domain Model
            }]
    
            relation foreach tran $trans {
                relation assign $tran State Event NewState Params
                set arc [$gr arc insert $State $NewState]
                $gr arc set $arc event $Event
                $gr arc set $arc params\
                        [relation list $Params Name -ascending Position]
            }
    
            return $gr
        } on error {result opts} {
            $gr destroy
            return -options $opts $result
        }
    }
    method stateModelDot {class_name} {
        package require Tcldot ;                                        # <1>
    
        my variable domain_name
    
        set dot [dotnew digraph]
        try {
            set smodel [relvar restrictone StateModel\
                    Domain $domain_name Model $class_name]
            if {[relation isempty $smodel]} {
                return $dot
            }
    
            $dot setnodeattributes shape box
            $dot setnodeattributes style filled
            $dot setnodeattributes fillcolor yellow
    
            set cr_state [pipe {
                relvar set CreationState |
                relation semijoin $smodel ~ |
                relation extend ~ cstup IsFinal boolean {false} |
                relation project ~ Name IsFinal
            }]
            set states [pipe {
                relvar set State |
                relation semijoin $smodel ~ |
                relation project ~ Name IsFinal |
                relation union ~ $cr_state
            }]
            #log::debug \n[relformat $states states]
    
            set node(@) [$dot addnode @ {*}{
                shape point
                fillcolor black
                label {}
                width 0.15
                fixedsize true
            }]
    
            set finals [relation restrictwith $states {$IsFinal}]
            if {[relation isnotempty $finals]} {
                set node(__x__) [$dot addnode __x__ {*}{
                    shape doublecircle
                    fillcolor black
                    label {}
                    width 0.15
                    fixedsize true
                }]
            }
    
            relation foreach state $states {
                relation assign $state
                if {$Name eq "@"} {
                    continue
                }
                set node($Name) [$dot addnode $Name\
                    label [string map {_ { }} $Name]\
                ]
                if {$IsFinal} {
                    set edge($Name,__x__) [$dot addedge $node($Name) $node(__x__)]
                }
            }
    
            if {[relation isempty $cr_state]} {
                set initialstate [relation extract $smodel InitialState]
                set edge(@,$initialstate)\
                        [$dot addedge $node(@) $node($initialstate)]
            } ;                                                             # <2>
    
            set statetrans [pipe {
                relvar set StateTransition |
                relation semijoin $smodel ~ |
                relation rename ~ State SrcState NewState State |
                rvajoin ~ [relvar set StateSignature] Signature |
                relation project ~ SrcState Event State Signature
            }]
            #puts [relformat $statetrans statetrans]
    
            relation foreach statetran $statetrans {
                relation assign $statetran
                set evt_label [string map {_ { }} $Event]
                if {[relation isnotempty $Signature]} {
                    set params [pipe {
                        relvar restrictone ParameterSignature Domain $domain_name\
                            PSigID [relation extract $Signature PSigID] |
                        relation semijoin ~ [relvar set Parameter] |
                        relation list ~ Name -ascending Position |
                        join ~ ,
                    }]
                    append evt_label "(" $params ")"
                }
                set edge($SrcState,$State) [$dot addedge\
                        $node($SrcState) $node($State)\
                        label $evt_label
                ]
            }
    
            return $dot
        } on error {result opts} {
            rename $dot {}
            return -options $opts $result
        }
    }
}
proc ::miccautil::dfs {graph {start {}}} {
    if {$start eq {}} {
        set start [$graph get initialstate]
    }

    set nodes [$graph nodes]
    foreach node $nodes {
        $graph node set $node pre 0
        $graph node set $node rpost 0
    }
    variable preorder 1
    variable postorder [llength $nodes]
    ClassifyNode $graph $start
    return
}
proc ::miccautil::ClassifyNode {graph node} {
    variable preorder
    set thisPre $preorder
    $graph node set $node pre $thisPre
    incr preorder
    set arcList [$graph arcs -out $node]

    foreach arc $arcList {
        set succ [$graph arc target $arc]
        set succPre [$graph node get $succ pre]
        if {$succPre == 0} {
            $graph arc set $arc type tree
            ClassifyNode $graph $succ
        } elseif {[$graph node get $succ rpost] == 0} {
            $graph arc set $arc type back
        } elseif {$thisPre < $succPre} {
            $graph arc set $arc type frwd
        } else {
            $graph arc set $arc type cross
        }
    }
    variable postorder
    $graph node set $node rpost $postorder
    incr postorder -1

    return
}
proc ::miccautil::spanningTree {graph {start {}}} {
    set span [::struct::graph]
    $span = $graph
    dfs $span $start

    set ffunc [lambda {graph arc} {
        expr {[$graph arc get $arc type] ne "tree"}
    }]
    set non_tree [$span arcs -key type -filter $ffunc]
    $span arc delete {*}$non_tree

    return $span
}
proc ::miccautil::graphToDot {graph {edgekeys {}} {nodekeys {}}} {
    package require Tcldot

    set dot_graph [dotnew digraph]
    $dot_graph setnodeattributes shape box
    $dot_graph setnodeattributes style filled
    $dot_graph setnodeattributes fillcolor yellow

    foreach node [$graph nodes] {
        set dot_node [$dot_graph addnode $node]
        if {$node eq "@"} {
            $dot_node setattributes\
                shape circle fontcolor white fillcolor black
            set label_value {}
        } elseif {$node eq "__x__"} {
            $dot_node setattributes\
                shape doublecircle fontcolor white fillcolor black
            set label_value {}
        } else {
            set label_value [string map {_ { }} $node]
        }
        set node_attrs [$graph node keys $node]
        set node_keys [lmap nodekey $nodekeys {
            expr {$nodekey in $node_attrs ?
                "$nodekey=[$graph node get $node $nodekey]" : [continue]}
        }]
        if {$label_value ne {}} {
            set label_value [concat [list $label_value] $node_keys]
        } else {
            set label_value $node_keys
        }
        set label_value [join $label_value "\\n"]
        $dot_node setattributes label $label_value
    }

    foreach arc [$graph arcs] {
        set source [$graph arc source $arc]
        set target [$graph arc target $arc]
        set dot_edge [$dot_graph addedge $source $target]
        set label_value {}
        set nl {}
        set edge_attrs [$graph arc keys $arc]
        foreach edgekey $edgekeys {
            if {$edgekey in $edge_attrs} {
                append label_value $nl\
                        ${edgekey}=[$graph arc get $arc $edgekey]
                set nl "\\n"
            }
        }
        $dot_edge setattributes label $label_value
    }

    return $dot_graph
}

package provide miccautil $::miccautil::version

