#!/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 http://www.tcl.tk/)}
		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