'''What is Fiction! ?'''
It is a new text-based adventure game. It is a small, object-oriented, but full-featured interactive fiction engine.

It makes use of features of [Tcl] 8.5, and it has no dependency on [Tk], as it is text-only.
It supports a sophisticated I18N mechanism.
It requires [Basique - OO-like namespaces]. Just put a file named basique.tcl in the directory of Fiction! and it will work.
----
[Sarnold] is the creator of this software. It is delivered under a BSD-like license, like Tcl.
----
2008-07-28: [Sarnold] added the ability to save and restore games.
----
'''The code'''
======
#!/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 iassert {expr msg} {if {![uplevel 1 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]}
# 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 __destroy__ {} {
		[-> quality] 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 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]
			warn [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__ {} {[-> quality] 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 {} {warn "[i "You take"] [the]"; eval [-> take] }
	proc act val {set [. act] $val}
	proc Act {} {eval [-> act]}
	proc watch {} {warn "[i "There is"] [a]."}
}

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}
		}
		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
		iassert {$count == 0} "too many words"
		set result
	}	
	proc Take {args} {
		grab [seek1 $args]
	}
	proc Drop {args} {
		drop [seek1 $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] {$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
		if {[catch {set where [$place where $way]}]} {
			error [i "There is no way like this"]
		}
		$place Leave
		$where Arrive
		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 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?"] [$what the]]
		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 __destroy__ {} {[-> quality] destroy}
	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."]]
	}
	proc a {} {string trim "[phrase a] [-> name]"}
	proc watch {} {warn "[i "Here is"] [a]."}
}
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} [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}
	} 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 {
	"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 %s to %s." "Il y a une voie au %s 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"
}


## 
 #  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 say "Bonjour!"
	Claire says "Bonjour! Comment vous appelez-vous?"
	I say "Julien. Et vous?"
	Claire says "Claire. Enchantée, Julien!"
	Claire set-name Claire
	Claire set-person yes
	I say "Enchanté!"
	Fleur use Claire {
		Claire says "Oh, merci beaucoup!"
	}
	Claire talk dummy
}

## End of material  ##



Ego new I Home
eval main $argv
======
----
!!!!!!
%| [Category Games] |%
!!!!!!