Programming:Tcl Fiction! (unauthorized copy)

From Robupixipedia
Jump to navigationJump to search
THIS IS AN UNAUTHORIZED COPY OF THE PAGE Fiction!.  THE ORIGINAL PAGE IS HERE: Fiction!

(I'm making a copy just in case 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 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 Basique - OO-like namespaces. Just put the source 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.



The code <source lang="tcl">

  1. !/usr/bin/env tclsh

package require Tcl 8.5

  1. the OO layer

source basique.tcl

  1. bootstrapping

set debug yes

  1. the standalone demo version

set demo yes

  1. I18N
  2. 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 }

  1. 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]}


  1. ack et fail: shorthands to return true and return false

interp alias {} ack {} return true interp alias {} fail {} return false

  1. a useful proc: removes an element from a list,
  2. 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])"} }

  1. 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]} }

  1. returns a random element within arguments

proc random {args} { lindex $args [expr {int(rand()*[llength $args])}] }

  1. 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}

  1. 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 Template: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 } } }

  1. 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}

    1. End of material ##


Ego new I Home eval main $argv </source>