#!/usr/bin/env tclsh

package require Tcl 8.5
# the OO layer
source basique.tcl

# bootstrapping
set debug yes
# the standalone demo version
set demo yes

# I18N
# Change this to "en" if you want messages in English
set lang fr
if $demo {set lang en}

proc assert {expr {msg "assertion failed"}} {if {![uplevel 1 [list expr $expr]]} {error $msg}}
proc iassert {expr {msg "assertion failed"}} {if {![uplevel 1 [list expr $expr]]} {error [i $msg]}}
proc ? {bool iftrue iffalse} {
        if {$bool} {return $iftrue}
        set iffalse
}
proc way? {to} {
        set to [string tolower $to]
        set to [string map {south s north n west w east e} $to]
        iassert [regexp {[senw]|s[ew]|n[ew]|e[ns]|w[ns]} $to] "invalid direction"
        set to
}
# normalizes a namespace
proc nsnorm val {
        namespace eval $val namespace current
}
proc nseq {a b} {
        string equal [nsnorm $a] [nsnorm $b]
}

proc i {s} {
        if {$::lang eq "fr" && [info exists ::msg($s)]} {
                return $::msg($s)
        }
        set s
}

proc iputs {s} {warn [i $s]}


# ack et fail: shorthands to return true and return false
interp alias {} ack {} return true
interp alias {} fail {} return false
# a useful proc: removes an element from a list,
# even with multiple elements
proc lremove {list elt} {
        while {[set i [lsearch -exact $list $elt]]>=0} {
                set list [lreplace $list $i $i]
        }
        set list
}
        

basique::class Room {
        variable name
        variable ways
        variable objs ""
        variable description
        proc __init__ {desc args} {
                # do not change set$opt to set $opt
                # because this is a dispatched command
                set-name [self]
                set-description $desc
                foreach {opt val} $args {[self]::set$opt $val}
        }
        proc __destroy__ {} {
                foreach o [-> objs] {$o destroy}
        }
        proc seek {seek} {
                instance
                set res ""
                foreach o $objs {
                        if {[$o match $seek]} {
                                lappend res $o
                        }
                }
                set res
        }
        proc watch {} {
                instance
                foreach o $objs {$o watch}
        }
        proc add {what} {
                lappend [. objs] $what
        }
        proc remove {a} {
                instance
                set objs [lremove $objs $a]
        }
        proc set-description val {set [. description] $val}
        proc set-name val {set [. name] $val}
        proc ways {to name} {
                set to [way? $to]
                variable ways
                dict set ways $to $name
        }
        proc where {way} {
                variable ways
                dict get $ways [way? $way]
        }
        proc object {args} {
                Object new {*}$args -place [self]
        }
        proc person {args} {
                Person new {*}$args -place [self]
        }
        proc here {} {
                warn [-> description]
                dict for {dir room} [-> ways] {
                        set dir [join [split $dir ""] -]
                        # set direction in english
                        set dir [string map {n north w west e east s south} $dir]
                        # i18n
                        warn [format [i [format "There is a way to the %s to %%s." $dir]] [$room -> name]]
                }
        }
        variable leave StdLeave
        proc StdLeave {} {
                warn "[i "You leave"] [-> name]."
        }
        proc Leave {} {eval [-> leave]}
}
                
basique::class Object {
        variable name
        variable use ""
        variable take {ack "you take the object"}
        variable act fail
        variable place Home
        variable desc "No desc"
        proc __init__ {desc args} {
                set-name [self]
                set [. desc] $desc
                foreach {opt val} $args {[self]::set$opt $val}
        }
        proc __destroy__ {} {[-> quality] destroy}
        proc in val {nseq $val [-> place]}
        proc set-place val {
                [-> place] remove [self]
                set [. place] $val
                $val add [self]
        }
        proc set-name val {set [. name] $val}
        proc match seek {string match -nocase $seek [-> name]}
        proc use {onwhat body} {dict set [. use] [nsnorm $onwhat] $body}
        proc Use {onwhat} {
                variable use
                set onwhat [nsnorm $onwhat]
                if {[dict exists $use $onwhat]} {
                        eval [dict get $use $onwhat]
                } else {
                        iputs "Nothing happens."
                }
        }
        proc take {val msg} {set [. take] [handler $val $msg]}
        proc Take {} {handle [-> take] }
        proc act {val msg} {set [. act] [handler $val $msg]}
        proc Act {} {handle [-> act]}
        proc watch {} {iputs "[-> desc] ([-> name])"}
}

# some small procs to handle message and body of a handler
proc handler {val msg} {
        list $val $msg
}
proc handle {n} {
        iputs [lindex $n 1]
        uplevel 1 [lindex $n 0]
}
basique::class Person {
        variable name
        variable inventory ""
        variable talk {default dummy}
        variable place Home
        variable state default
        variable description
        proc __init__ {args} {
                set-name [self]
                foreach {opt val} $args {[self]::set$opt $val}
        }
        proc set-state val {set [. state] $val}
        proc set-place val {
                [-> place] remove [self]
                set [. place] $val
                $val add [self]
        }
        proc watch {} {
                iputs [-> description]
        }
        proc gives {person obj} {
                $obj set-place $person
        }
        proc set-description val {set [. description] $val}
        proc The {} {string trim "[phrase The] [-> name]"}
        proc set-name val {
            set [. name] $val
            set-description [format [i "Here is %s."] [-> name]]
        }
        proc match seek {string match $seek [-> name]}
        proc set-talk val {talk $val}
        proc talk args {
                assert {[llength $args]>0}
                set val [lindex $args end]
                set state [getopts [lrange $args 0 end-1] -state default]
                dict set [. talk] $state $val
        }
        proc says {txt} {warn "[-> name]: $txt"}
        
        proc object {args} {
                lappend [. inventory] [Object new {*}$args]
        }
        proc Talk {args} {eval [dict get [-> talk] [-> state]]}
        proc dummy {} {
                warn [random [i "Talk less and act much!"] [i "Nothing happens."]]
        }
}

basique::class Ego {
        variable inventory ""
        variable place
        variable history ""
        variable score 0
        proc __init__ {where} {puts {Fiction! (c) Stephane Arnold 2008
BSD-like Tcl license (see https://www.tcl-lang.org/)}
                set [. place] $where
        }
        proc __destroy__ {} {
                foreach o [-> inventory] {$o destroy}
                [-> place] destroy
        }
        proc register {args} {
                switch -- [lindex $args 0] {
                        Save {}
                        default {lappend [. history] $args}
                }
        }
        proc score {n} {incr [. score] $n}
        proc WinTheGame {} {
                iputs Congratulations!
                PutScore
        }
        proc LoseTheGame {} {
                iputs Sorry...
                PutScore
        }
        proc Save {args} {
                warn [format [i "This will save the current game to '%s'"] $args]
                puts -nonewline [i "Are you sure ? (y/n) "]
                flush stdout
                gets stdin line
                if {![string equal $line [i y]]} {
                        iputs "Save aborted."
                        return
                }
                if {[catch {
                        set fd [open $args w]
                        # we write the history to a file
                        foreach l [-> history] {puts $fd $l}
                        close $fd
                } msg]} {
                        error [format [i "Cannot write to '%s': %s"] $args $msg]
                }
                iputs "Game saved"
        }                        
        proc say {txt} {warn "[i I]: $txt"}
        proc match {match} {
                set res ""
                foreach o [-> inventory] {
                        if {[$o match *$match*]} {lappend res $o}
                }
                concat $res [[-> place] seek *$match*]
        }
        proc seekN {n list} {
                if {$n == 1} {return [seek $list]}
                set i [llength $list]
                incr i -1
                while {[llength [match [lrange $list 0 $i]]]!=1} {
                        incr i -1
                        if {$i < 0} {error "[i "cannot find object or person"]: $list"}
                }
                concat [match [lrange $list 0 $i]] [seekN [incr n -1] [lrange $list [expr {$i+1}] end]]
        }
        proc seek {list} {
                # seek for an object or a person matching a list of strings
                set match [match $list]
                if {[llength $match] == 0} {
                        error "[i "cannot find object or person"]: $list"                        
                }
                if {[llength $match]>1} {return [probe $match]}
                return [lindex $match 0]
        }
        proc probe list {
                iputs "Did you mean?"
                fori i x $list {warn "[expr {$i+1}]: [$x -> name]"}
                while yes {
                        warn -nonewline "1-[llength $list]? "
                        flush stdout
                        gets stdin answer
                        if {![string is integer $answer]} { 
                                iputs "must be an integer"
                                continue
                        }
                        if {$answer >0 && $answer <= [llength $list]} {
                                return [lindex $list [expr {$answer -1}]]
                        }
                }
                # dead end
        }
        proc Take {args} {
                grab [seek $args]
        }
        proc Drop {args} {
                drop [seek $args]
        }
        proc PutScore {} {warn [format [i "Your score: %d points."] [-> score]]}
        proc Inv {} {
                PutScore
                if {[llength [-> inventory]]==0} {
                        iputs "Nothing in your pockets."
                        return
                }
                iputs "In your pockets:"
                foreach i [-> inventory] {puts "- [$i -> name]"}
        }
        proc Look {} {
                [-> place] here
                [-> place] watch
        }
        proc Help {} {
                puts [set ::Help_$::lang]
        }
        proc Exit {} {
            puts -nonewline [i "Are you sure you want to quit ? (y/n) "]
            flush stdout
            gets stdin c
            if {[string equal $c [i y]]} exit
        }
        proc Go {way} {
                variable place
                if {[catch {set where [$place where $way]}]} {
                        error [i "There is no way like this"]
                }
                $place Leave
                $where here
                set place $where
        }
        proc grab {what} {
                iassert {![$what in [self]]} "I already have it."
                assert {[$what in [-> place]]} "[i "cannot take"] [$what -> name]."
                assert [$what Take] "[i "cannot take"] [$what -> name]."
                $what set-place I
        }
        proc add val {
                lappend [. inventory] [nsnorm $val]
        }
        proc drop {what} {
                puts "[i "You drop"] [$what -> name]"
                $what set-place [-> place]
        }
        # to talk with people
        proc Talk {args} {
            [seek $args] Talk
        }
        proc remove {what} {
                instance
                assert {[lsearch -exact $inventory $what]>=0} "[i "no such object"]: $what"
                set inventory [lremove $inventory $what]
        }
        proc Use {args} {
                eval use [seekN 2 $args]
        }
        proc use {what onwhat} {
                assert {[$what in [self]]} "[i "I do not have"] [$what -> name]."
                $what Use $onwhat
        }
        proc act {what} {
                assert {[$what in [self]] || [$what in [-> place]]} "[i "cannot use"] [$what -> name]."
                $what Act
        }
        proc Act {args} {act [seek $args]}
}

# returns a random element within arguments
proc random {args} {
        lindex $args [expr {int(rand()*[llength $args])}]
}
# manage options
proc getopts {alist opt default} {
        if {[llength $alist] == 0} {
                return $default
        }
        assert {[llength $alist]%2 == 0}
        foreach {key val} $alist {
                if {$key eq $opt} {return $val}
        }
        return $default
}

proc fori {x var lst body} {
        uplevel 1 set $x 0
        uplevel 1 [list foreach $var $lst "$body\nincr $x"]
}

interp alias {} warn {} puts
proc Direction {s} {
        set s [Direction_$::lang $s]
        iassert [regexp {^([nsew]|n[we]|s[ew]|w[ns]|e[ns])$} $s] "invalid direction"
        list Go $s
}
proc Direction_en {s} {
        string map {- "" north n east e west w south s} $s
}
proc Direction_fr s {
        string map {est e o w} [string map {- "" nord n ouest o sud s} $s]
}
proc cmd {word} {
        if {![catch {
                set dir [Direction $word]
        }]} {
                return $dir
        }
        set commands [dict create fr {
                quitter Exit
                exit Exit
                laisser Drop
                prendre Take
                parler Talk
                utiliser Use
                actionner Act
                regarder Look
                va Go
                aller Go
                inventaire Inv
                aider Help
                sauver Save
        } en {
                quit Exit
                exit Exit
                drop Drop
                take Take
                talk Talk
                use Use
                act Act
                look Look
                go Go
                inventory Inv
                help Help
                save Save
        }]
        set res ""
        foreach {name cmd} [dict get $commands $::lang] {
                if {[string match $word* $name]} {
                        lappend res $cmd
                }
        }
        if {[llength $res]==1} {return [lindex $res 0]}
        error "I do not understand"
}
proc dummy {word} {
        expr {[lsearch [set ::dummy_$::lang] $word]>=0}
}
set dummy_en {a the on with}
set dummy_fr {à un une la le les des sur avec}
# set printing to stdout on/off
proc Warn {bool} {
        if {$bool} {
                proc warn {s} {puts $s; after 300}
        } else {
                proc warn {s} {}
        }
}

set Help_en {Commands are:
quit/exit        Exit the game
n-s-w-e                Go to the north, south...
take obj        Take an object
drop obj        Drop an object
look                Take a look upon your environment
act obj                Activate an object
talk person        Talk to a person
use obj what        Use an object on something/someone
go n-s-w-e        Go to the north, south...}

set Help_fr {Voici les ordres que je comprends :
quitter/exit                Termine le jeu
n-s-o-e                        Se déplacer au nord, sud,....
prendre obj                Prendre un objet
laisser obj                Lacher un objet
regarder                Regarder autour de soi
actionner obj                Actionner un objet
parler personne                Parler à quelqu'un
utiliser obj chose        Utiliser un objet sur qq chose ou qq'un
go n-s-o-e                Se déplacer}
proc main {{file ""}} {
        if {$file ne ""} {
                puts [format [i "Restoring data from %s..."] $file]
                Warn off
                if {[catch {
                        set i 0
                        set fd [open $file]
                        while {![eof $fd]} {
                                gets $fd line
                                if {$line ne ""} {
                                        catch {eval I $line}
                                        eval I register $line
                                }
                                # display a progress indicator
                                incr i
                                if {$i % 100 == 0} {puts -nonewline .}
                        }
                        close $fd
                } msg info]} {
                        puts $msg
                        puts stderr $info
                        exit
                }
                Warn on
        }
        I Look
        while 1 {
                puts -nonewline "> "
                flush stdout
                gets stdin line
                if {[catch {cmd [lindex $line 0]} cmd]} {
                        iputs "I do not understand, please type help"
                        continue
                }
                # filters dummy words (to, a, the, ...)
                # in any language
                set res [list]
                foreach i [lrange $line 1 end] {
                        if {![dummy $i]} {lappend res $i}
                }
                if {[catch {eval I $cmd $res} msg info]} {
                        puts $msg
                        if {$::debug} {puts $info}
                } else {
                        eval I register $cmd $res
                }
        }
}

# I18N en Francais
array set msg {
        "assertion failed" "échec de contrôle de données"
        "Restoring data from %s..." "Restauration de la partie stockée dans %s..."
        "Talk less and act much!" "Moins de paroles, plus d'action !"
        "too many words" "trop de mots dans la commande"
        "You leave" "Vous quittez"
        "He is" "C'est un"
        "Here is" "Il y a"
        "This will save the current game to '%s'" "Cela enregistrera dans '%s' la partie en cours."
        "Game saved" "Jeu sauvegardé"
        "Are you sure ? (y/n) " "Êtes-vous sûr ? (o/n) "
        "You take" "Vous prenez"
        "Nothing happens." "Rien ne se passe."
        "There is a way to the north to %s." "Il y a une voie au nord vers %s."
        "There is a way to the south to %s." "Il y a une voie au sud vers %s."
        "There is a way to the west to %s." "Il y a une voie à l'ouest vers %s."
        "There is a way to the east to %s." "Il y a une voie à l'est vers %s."
        north nord south sud west ouest east est 
        "There is no way like this" "Il n'y a pas de voie dans cette direction."
        "You drop" "Vous déposez" I Moi
        "There is" "Il y a"
        "use %s on what?" "Sur quoi voulez-vous utiliser %s ?"
        "Your score: %d points." "Votre score est de %d points."
        "In your pockets:" "Dans tes poches :"
        "Nothing in your pockets." "Tu n'as rien dans les poches."
        "I do not understand, please type help" "Je ne comprends pas. (tape aide)"
        "Are you sure you want to quit ? (y/n) " "Etes-vous sûr de vouloir quitter ce programme ? (o/n) "
        y o
        "Cannot write to '%s': %s" "Impossible d'accéder à '%s' : %s"
        "cannot find object or person" "je ne trouve pas cet objet ou cette personne"
        "Here is %s." "Il y a %s."
}


## 
 #  Testing material
 ##
if $demo {
    Room new Home {Home, sweet home...} -name {your home} 
    Home ways n Garden
    Room new Garden {You stand in a wonderful garden with flowers of all essences.} -name "the garden"
    Home object Rasoir {There is a razor that is really dirty.} -name "a razor"
    Garden ways s Home
    Rasoir take ack {You take the razor.}
    Rasoir act ack {You are shaving. Mmmh, this is nice.}
    Garden object Flower {A beautiful rose.} -name "a flower"
    Flower take ack {You take this rose.}
    Garden person Claire -name "a girl" -state unknown
    Claire talk -state unknown {
        I say "Hi! How do you do?"
        Claire says "I'm Claire. How do you do?"
        I say "I'm Julien. Nice to meet you!"
        Claire says "Nice to meet you, Julien!"
        Claire set-name Claire
        Claire set-state default
    }        
    Claire talk -state default dummy
    Flower use Claire {
        Claire says "Oh, thanks a lot! I love these flowers."
    }
} else {source aventure.txt}
## End of material  ##



Ego new I Home
eval main $argv