# discrete_ships.tcl --
#     Discrete events simulation: a series of ships
#     entering and exiting a harbour
#
#     TODO:
#     NIce graphical display of the simulation
#
package require Tcl 8.5
package require Tk
package require Plotchart

# createResource --
#     Create a resource consisting of a number of
#     identical objects
#
# Arguments:
#     name         Name of the resource
#     amount       Number of objects
#
# Returns:
#     dictionary containing the relevant information
#
proc createResource {name amount} {

    global resources

    dict set resources $name [dict create total $amount available $amount]
}

# acquireResource --
#     Acquire a certain number of objects in the resource
#
# Arguments:
#     objectId      ID of the object that wants the resource
#     resourceName  Variable representing the resource
#     amount        Amount to acquire
#     newstate      Name of the new state if the resource is acquired
#
# Returns:
#     Whether successful (1) or not (0)
#
# Side effects:
#     If successful, the state of the object is changed to the new
#     state, and the amount of available resources is reduced.
#     If not successful, the object remains in the same state
#
proc acquireResource {objectId resourceName amount newstate} {

    global debug
    global resources
    global objects
    global time

    if { ! [dict exists $resources $resourceName] } {
        return -code error "Resource does not exist: $resourceName"
    }

    #
    # Are there enough items in the resource left?
    #
    set available [dict get $resources $resourceName available]

    if { $available < $amount } {

        if { $debug } {
            puts "Time: $time -- [getProperty $objectId name] ($objectId) cannot acquire $resourceName"
            puts "      Available: $available -- requested: $amount"
        }

        newRequest $objectId

        return 0
    }

    #
    # We can "acquire" the resource
    #

    dict set resources $resourceName available [expr {$available-$amount}]
    dict set objects   $objectId     state     $newstate

    if { $debug } {
        puts "Time: $time -- [getProperty $objectId name] ($objectId) acquired $resourceName"
        puts "      Amount: $amount"
    }

    return 1
}

# releaseResource --
#     Release a certain number of objects to the resource
#
# Arguments:
#     resourceName  Variable representing the resource
#     amount        Amount to release
#
# Returns:
#     Nothing
#
proc releaseResource {resourceName amount} {

    global resources
    global debug
    global time

    #
    # Sanity check: we do not get more than the original amount?
    #
    if { ! [dict exists $resources $resourceName] } {
        return -code error "Resource does not exist: $resourceName"
    }

    set total     [dict get $resources $resourceName total]
    set available [dict get $resources $resourceName available]

    if { $available + $amount > $total } {
        puts "Time: $time -- releasing $resourceName: more than the original!"
        puts "      Available: $available -- released: $amount -- original amount: $total"
        return -code error "Too many resources released"
    }

    #
    # We can "release" the resource
    #

    dict set resources $resourceName available [expr {$available+$amount}]

    if { $debug } {
        puts "Time: $time -- $resourceName released"
        puts "      Amount: $amount"
    }
}

# stopSimulation --
#     Arrange for the simulation to be stopped
#
# Arguments:
#     None
#
# Returns:
#     Nothing
#
# Side effects:
#     Sets the variable stop to make sure the event loop stops
#
proc stopSimulation {} {
    global stop

    set stop 1
}

# newEvent --
#     Create a new event
#
# Arguments:
#     delay          Delay wrt current time
#     objectId       Identification of the object
#     newstate       New state of the object when the event fires
#                    (optional)
#
# Returns:
#     Nothing
#
proc newEvent {delay objectId {newstate {}}} {
    global events
    global time
    global debug

    if { $debug } {
        puts "Event scheduled: $delay -- $objectId"
    }

    if { $delay < 0.0 } {
        return -code error "Can not schedule events in the past - delay must be non-negative"
    }

    lappend events [list [expr {$time + $delay}] $objectId $newstate]
    set events [lsort -index 0 -real $events]
}

# newRequest --
#     Create a request for some resource
#
# Arguments:
#     objectId       Identification of the object
#
# Returns:
#     Nothing
#
proc newRequest {objectId} {
    global newRequests
    global debug

    if { [lsearch $newRequests $objectId] < 0 } {
        lappend newRequests $objectId

        if { $debug } {
            puts "Request scheduled: $objectId"
        }
    }
}

# newState --
#     Set the state of an object
#
# Arguments:
#     objectId     ID of the object
#     state        New state
#
# Returns:
#     Nothing
#
proc newState {objectId state} {

    global objects

    dict set objects $objectId state $state
}

# getProperty --
#     Get a particular property of an object
#
# Arguments:
#     objectId     ID of the object
#     property     Name of the property
#
# Returns:
#     Value of the property
#
proc getProperty {objectId property} {

    global objects

    return [dict get $objects $objectId $property]
}

# setProperty --
#     Set a particular property of an object
#
# Arguments:
#     objectId     ID of the object
#     property     Name of the property
#     value        Value of the property
#
# Returns:
#     Nothing
#
proc setProperty {objectId property value} {

    global objects

    dict set objects $objectId $property $value
}

# createObject --
#     Create a new object in the simulation
#
# Arguments:
#     name         (Preferably) unique name for the object
#     objProc      Name of the object procedure
#     args         Key-value pairs defining the properties
#
# Returns:
#     ID of the dictionary representing the object
#
proc createObject {name objProc args} {

    global objectCount
    global objects
    global debug
    global time

    #
    # Create the object with its user-defined properties
    #
    # TODO: check that the name is unique - or should we?
    #
    incr objectCount
    set object [dict create name $name objProc $objProc state "CREATED"]

    foreach {key value} $args {
        if { [lsearch {name objProc state} $key] < 0 } {
            dict set object $key $value
        } else {
            return -code error "You should not use a property named $key in an object"
        }
    }

    if { $debug } {
        puts "Object created: $objectCount ($name) at time $time"
    }

    dict set objects $objectCount $object

    #
    # Make the event system aware of it
    #
    newEvent 0 $objectCount ;# TODO: how do we keep track of the objects?

    return $objectCount
}

# deleteObject --
#     Remove the object (any pending events related to it are ignored)
#
# Arguments:
#     objectId     ID of the object
#
# Returns:
#     Nothing
#
proc deleteObject {objectId} {
    global debug
    global objects

    if { $debug } {
        puts "Deleted object: $objectId ([dict get $objects $objectId name])"
    }
    set objects [dict remove $objects $objectId]

}

# doEvents --
#     Handle the events
#
# Arguments:
#     None
#
# Returns:
#     Nothing
#
# Side effects:
#     Handle all events until a stop is requested or there are
#     no more events to be processed.
#
proc doEvents {} {

    global debug
    global time
    global resources
    global objects
    global events
    global newRequests
    global stop

    while { [llength $events] > 0 } {

        set event  [lindex $events 0]
        set events [lrange $events 1 end]

        foreach {time objectId newstate} $event {break}

        if { $stop } {
            return
        }
        if { ! [dict exists $objects $objectId] } {
            continue
        }

        #
        # Let the object handle the event
        #
        set object [dict get $objects $objectId]

        if { $newstate != "" } {
            dict set objects $objectId state $newstate
        }

        [dict get $object objProc] $objectId $time [dict get $object state]

        #
        # Handle the requests for resources that could not be
        # satisfied immediately
        #
        set requests    $newRequests
        set newRequests {}

        foreach objectId $requests {
            set object [dict get $objects $objectId]
            [dict get $object objProc] $objectId $time [dict get $object state]
        }
    }
}

# shipsCreate --
#     Procedure to randomly create new ships
#
# Arguments:
#     objectId        The "creation" object's ID
#     time            Current simulation time
#     state           State of the object
#
# Returns:
#     Nothing
#
# Side effects:
#     New ships are created at a given rate
#
proc shipsCreate {objectId time state} {

    if { $state == "CREATED" } {

        set rate [getProperty $objectId rate]
        set rate [expr {$rate/10.0}] ;# ten events per hour
        newState $objectId "RUNNING"
        setProperty $objectId rate $rate

    } else {

        if { $time > [getProperty $objectId endTime] } {
            stopSimulation
            return
        }
        set rate [getProperty $objectId rate]
        if { rand() < $rate } {
            createObject ship shipLifeCycle startTime $time waitTime 0.0 endTime 0.0
        }

    }

    newEvent 0.1 $objectId
}

# shipLifeCycle --
#     Procedure representing the life cycle of a "ship" object
#
# Arguments:
#     objectName      The object itself (name of variable)
#     time            Current simulation time
#     state           State of the object
#
# Returns:
#     Nothing
#
# Side effects:
#     Changes in the state of the object, new events, etc
#
# Note:
#     When the ship arrives at the harbour (the creation event)
#     it will need two tugs to enter the harbour. This takes
#     one hour.
#     When it reaches the quay, it gets unloaded (which takes
#     two hours) and then leaves the harbour again (aided by
#     one tug this time) in half an hour.
#     When it has left the harbour, it leaves the simulation
#     and the object is destroyed.
#
proc shipLifeCycle {objectId time state} {
    global allShips

    switch -- $state {
        "CREATED" {
            if { [acquireResource $objectId tugs 2 "ENTER"] } {
                setProperty $objectId waitTime [expr {$time - [getProperty $objectId startTime]}]
                newEvent 1 $objectId
            }
        }
        "ENTER" {
            releaseResource tugs 2
            newState $objectId "LEAVE"
            newEvent 2 $objectId

            setProperty $objectId leaveTime [expr {$time + 2.0}]
        }
        "LEAVE" {
            if { [acquireResource $objectId tugs 1 "LEFT"] } {
                set waitTime [getProperty $objectId waitTime]
                setProperty $objectId waitTime [expr {$waitTime + $time - [getProperty $objectId leaveTime]}]
                newEvent 0.5 $objectId
            }
        }
        "LEFT" {
            set totalTime [expr {$time - [getProperty $objectId startTime]}]
            set waitTime  [getProperty $objectId waitTime]

            set  allShips(totalTime) [expr {$allShips(totalTime) + $totalTime}]
            set  allShips(waitTime)  [expr {$allShips(waitTime) + $waitTime}]
            incr allShips(number)

            set totalAvg [expr {$allShips(totalTime)/$allShips(number)}]
            set waitAvg  [expr {$allShips(waitTime)/$allShips(number)}]
            set number   $allShips(number)

            $::p plot total $number $totalAvg
            $::p plot wait  $number $waitAvg
            update idletasks

            releaseResource tugs 1

            deleteObject $objectId
        }
    }
}


# main --
#     A simple simulation
#

#
# Initialise the library - should be hidden
#
set debug 0
set time  0
set stop  0
set resources   [dict create]
set newRequests [list]
set events      [list]

#
# Create a plot window to show the results graphically
#
catch {
    console show
}
pack [canvas .c -width 400 -height 300]

set p [::Plotchart::createXYPlot .c {0 300 50} {0 20 5}]

$p title "Average total and wait time"
$p dataconfig total -type symbol -symbol plus
$p dataconfig wait  -type symbol -symbol cross -colour red

#
# Start of simulation:
# We have three tugs to work with
#
createResource "tugs" 3

#
# Create the ships at a certain rate
# (rate is number of ships per hour)
#
#set ships [createObject "ShipsCreate" shipsCreate endTime 300 rate 1.0]
set ships [createObject "ShipsCreate" shipsCreate endTime 300 rate 0.9]

set allShips(totalTime) 0.0
set allShips(waitTime)  0.0
set allShips(number)    0

doEvents

puts "\nStatistics:\n"

puts "Mean total time: [expr {$allShips(totalTime)/$allShips(number)}]"
puts "Mean wait time:  [expr {$allShips(waitTime)/$allShips(number)}]"
puts "Number of ships: $allShips(number)"