#!/usr/bin/env tclsh

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

# bootstrapping
set debug no

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


proc assert {expr msg} {if {![uplevel 1 expr $expr]} {error $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]
	assert [regexp {[senw]|s[ew]|n[ew]|e[ns]|w[ns]} $to] [i "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} {puts [i $s]}
# internationalize phrases
basique::class Quality {
	variable gender m
	variable plural false
	variable person false
	proc __init__ {} {
	}
	proc set-gender val {
		assert {[regexp male|female|neutral $val]} "unknown gender: $val"
		set [. gender] $val
	}
	proc set-plural val {set [. plural] $val}
	proc set-person val {set [. person] $val}
	proc quality {} {
		return [string index [-> gender] 0][? [-> person] n [? [-> plural] p s]]
	}
	proc phrase {s} {
		set quality [quality]
		global phrases lang
		while {[string length $quality]}  {
			if {[info exists phrases($s,$lang,$quality)]} {
				return $phrases($s,$lang,$quality)
			}
			if {$quality eq ""} {error "cannot find $s"}
			set quality [string range $quality 1 end]
		}
	}
}

array set phrases {
	a,en,s a
	a,en, ""
	a,fr,ms un
	a,fr,fs une
	a,fr,p des
	a,fr,n ""
	A,en,s A
	A,en, ""
	A,fr,ms Un
	A,fr,fs Une
	A,fr,p Des
	A,fr,n ""
	The,en, The
	The,en,n ""
	The,fr,fs La
	The,fr,ms Le
	the,fr,ms le
	the,fr,fs la
	The,fr,n ""
	the,fr,n ""
	the,en, the
	the,en,n ""
}

# ack et fail : shorthands to return true and return false
interp alias {} ack {} return true
interp alias {} fail {} return false
# a useful proc
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
	variable quality
	proc __init__ {desc args} {
		# do not change set$opt to set $opt
		# because this is a dispatched command
		set-name [self]
		set [. quality] [Quality new %AUTO%]
		set-description $desc
		foreach {opt val} $args {[self]::set$opt $val}
	}
	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 set-gender val {[-> quality] set-gender $val}
	proc set-plural val {[-> quality] set-plural $val}
	proc set-person val {[-> quality] set-person $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]
	}
	variable arrive ""
	proc here {} {
		warn [-> description]
		dict for {dir room} [-> ways] {
			set dir [join [split $dir ""] -]
			set dir [string map [list n [i north] w [i west] e [i east] s [i south]] $dir]
			puts [format [i "There is a way to the %s to %s."] [i $dir] [$room -> name]]
		}
	}
	proc Arrive {} {
		eval [-> arrive]
		here
	}
	proc phrase {s} {[-> quality] phrase $s}
	variable leave StdLeave
	proc StdLeave {} {
		warn "[i "You leave"] [phrase the] [-> name]."
	}
	proc Leave {} {eval [-> leave]}
}
		
basique::class Object {
	variable name
	variable use ""
	variable take ack
	variable act fail
	variable place Home
	variable quality
	proc __init__ {args} {
		set-name [self]
		set [. quality] [Quality new %AUTO%]
		foreach {opt val} $args {[self]::set$opt $val}
	}
	proc __destroy__ {} {}
	proc in val {nseq $val [-> place]}
	proc set-place val {
		[-> place] remove [self]
		set [. place] $val
		$val add [self]
	}
	proc phrase {s} {[-> quality] phrase $s}
	proc set-gender val {[-> quality] set-gender $val}
	proc set-plural val {[-> quality] set-plural $val}
	proc set-name val {set [. name] $val}
	proc match seek {string match $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 {set [. take] $val}
	proc the {} {string trimleft "[phrase the] [-> name]"}
	proc a {} {string trimleft "[phrase a] [-> name]"}
	proc Take {} {puts "[i "You take"] [the]"; eval [-> take] }
	proc act val {set [. act] $val}
	proc Act {} {eval [-> act]}
	proc watch {} {puts "[i "There is"] [a]."}
}

basique::class Ego {
	variable inventory ""
	variable place
	proc __init__ {where} {puts {Fiction! (c) Stephane Arnold 2008
BSD-like Tcl license (see http://www.tcl.tk/)}
		set [. place] $where
		$where here
	}
	proc __destroy__ {} {
		foreach o [-> inventory] {$o destroy}
	}
	proc says {txt} {warn "[i I]: $txt"}
	proc match {match} {
		set res ""
		foreach o [-> inventory] {
			if {[$o match *$match*]} {lappend res $o}
		}
		set res [concat $res [[-> place] seek *$match*]]
	}
	proc seek {list} {
		# seek for an object or a person matching a list of strings
		set found ""
		while {[llength $list]} {
			set list [lassign $list a]
			lappend match $a
			if {[llength [match $match]] == 1} {
				set found [lindex [match $match] 0]
			} elseif {[llength $found]} {
				# we have found a match but with fewer words
				# we return the number of words remaining
				return [list [expr {1+[llength $list]}] $found]
			}
		}
		if {[llength $found]} {return [list 0 $found]}
		error [i "cannot find object or person"]
	}
	proc seek1 {list} {
		lassign [seek $list] count result
		assert {$count == 0} "too many words"
		set result
	}	
	proc Take {args} {
		grab [seek1 $args]
	}
	proc Drop {args} {
		drop [seek1 $args]
	}
	proc Inv {} {
		if {[llength [-> inventory]]==0} {
			iputs "Nothing in your pockets."
			return
		}
		iputs "In your pockets:"
		foreach i [-> inventory] {$i watch}
	}
	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
		set where [$place where $way]
		$place Leave
		$where Arrive
		set place $where
	}
	proc grab {what} {
		assert {![$what in [self]]} [i "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 the]"
		$what set-place [-> place]
	}
	# to talk with people
	proc Talk {args} {
	    [seek1 $args] Talk
	}
	proc remove {what} {
		instance
		set what [nsnorm $what]
		assert {[lsearch -exact $inventory $what]>=0} "[i "no such object"]: $what"
		set inventory [lremove $inventory $what]
	}
	proc Use {args} {
		lassign [seek $args] rest what
		assert {$rest>0} [format [i "use %s on what?"] $args]
		set onwhat [seek1 [lrange $args end-[incr rest -1] end]]
		use $what $onwhat
	}
	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 [seek1 $args]}
}

# returns a random element within arguments
proc random {args} {
	lindex $args [expr {int(rand()*[llength $args])}]
}

interp alias {} warn {} puts
basique::class Person {
	variable name
	variable quality
	variable talk dummy
	variable place Home
	proc __init__ {args} {
		set-name [self]
		set [. quality] [Quality new %AUTO%]
		foreach {opt val} $args {[self]::set$opt $val}
	}
	proc set-gender val {[-> quality] set-gender $val}
	proc set-person val {[-> quality] set-person $val}
	proc set-plural val {[-> quality] set-plural $val}
	proc set-place val {
		[-> place] remove [self]
		set [. place] $val
		$val add [self]
	}
	proc phrase val {[-> quality] phrase $val}
	proc The {} {string trim "[phrase The] [-> name]"}
	proc set-name val {set [. name] $val}
	proc match seek {string match $seek [-> name]}
	proc says {txt} {warn "[The]: $txt"}
	proc set-talk val {talk $val}
	proc talk val {set [. talk] $val}
	proc Talk {} {eval [-> talk]}
	proc dummy {} {
		warn [random [i "Talk less and act much!"]\
			[i "Nothing happens."] [phrase HeNotSpeak]]
	}
	proc a {} {string trim "[phrase a] [-> name]"}
	proc watch {} {puts "[i "Here is"] [a]."}
}
proc Direction {s} {
	set s [Direction_$::lang $s]
	assert [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} [string map {- "" nord n ouest o sud s} $s]
}
proc cmd {word} {
	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
	} en {
		quit Exit
		exit Exit
		drop Drop
		take Take
		talk Talk
		use Use
		act Act
		look Look
		go Go
		inventory Inv
		help Help
	}]
	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]}
	return [Direction $word]
}
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 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 {} {
	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}
		}
	}
}

# I18N en Francais
array set msg {
	"You leave" "Vous quittez"
	"He is" "C'est un"
	"Here is" "Il y a"
	"You take" "Vous prenez"
	"Nothing happens." "Rien ne se passe."
	"There is a way to the %s to %s." "Il y a une voie au %s vers %s."
	north nord south sud west ouest east est 
	"You drop" "Vous déposez" I Moi
	"There is" "Il y a"
	"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 find object or person" "je ne trouve pas cet objet ou cette personne"
}


## 
 #  Testing material
 ##

Room new Home {Home, sweet home...} -name {votre maison} -person yes
Home ways n Jardin
Room new Jardin {Vous êtes à présent au Jardin d'Eden... enfin presque!}
Jardin set-name "le jardin d'Eden"
Home object Rasoir -name rasoir
Jardin ways s Home
Rasoir take ack
Rasoir act {warn "Vous vous rasez, et ça vous fait du bien."; ack}
Jardin object Fleur -name fleur -gender female
Fleur take {warn "Ça sent drolement bon."; ack}
Jardin person Claire -name "jeune fille" -gender female
Claire talk {
	I says "Bonjour!"
	Claire says "Bonjour! Comment vous appelez-vous?"
	I says "Julien. Et vous?"
	Claire says "Claire. Enchantée, Julien!"
	Claire set-name Claire
	Claire set-person yes
	I says "Enchanté!"
	Fleur use Claire {
		Claire says "Oh, merci beaucoup!"
	}
	Claire talk dummy
}

## End of material  ##



Ego new I Home
main