Rob: Protected "Programming:Tcl Fiction! (unauthorized copy)": don't want anyone to muck with this copy; they should work with the original [edit=sysop:move=sysop]

2008-12-21T09:30:04Z

Protected "Programming:Tcl Fiction! (unauthorized copy)": don't want anyone to muck with this copy; they should work with the original [edit=sysop:move=sysop]

← Older revision	Revision as of 02:30, 21 December 2008
(No difference)

Rob: unauthorized copy (with some edits to make it work on MediaWiki

2008-12-21T09:19:55Z

unauthorized copy (with some edits to make it work on MediaWiki

New page

THIS IS AN UNAUTHORIZED COPY OF THE PAGE Fiction!. THE ORIGINAL PAGE IS HERE: [http://wiki.tcl.tk/21324 Fiction!]

(I'm making a copy just in case [http://wiki.tcl.tk http://wiki.tcl.tk] goes away, but with a great domain like that, I imagine it will be stable for a while.)

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

See also [http://wiki.tcl.tk/863 A text adventure game 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 simple I18N mechanism.
It requires [http://wiki.tcl.tk/15750 Basique - OO-like namespaces]. Just put the source file named basique.tcl in the directory of Fiction! and it will work.

----
[http://wiki.tcl.tk/9126 Sarnold] is the creator of this software. It is delivered under a BSD-like license, like Tcl.
----

'''The code'''
<source lang="tcl">
#!/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
</source>

Programming:Tcl Fiction! (unauthorized copy) - Revision history

Rob: Protected "Programming:Tcl Fiction! (unauthorized copy)": don't want anyone to muck with this copy; they should work with the original [edit=sysop:move=sysop]

Rob: unauthorized copy (with some edits to make it work on MediaWiki