RCRPG/Tcl: Difference between revisions
< RCRPG
Content added Content deleted
(some small fixes) |
m (Fixed syntax highlighting.) |
||
(6 intermediate revisions by 2 users not shown) | |||
Line 1: | Line 1: | ||
{{collection|RCRPG}}[[ |
{{collection|RCRPG}}[[implementation of task::RCRPG| ]] |
||
This [[Tcl]] version of [[RCRPG]] was typed and tested on a cellphone, so pardon my brevity. |
|||
<syntaxhighlight lang="tcl">#!/usr/bin/env tclsh |
|||
<lang Tcl> |
|||
#!/usr/bin/env tclsh |
|||
proc help args { |
proc help args { |
||
return "RosettaCode 3D single user dungeon in Tcl. Type a command: |
return "RosettaCode 3D single user dungeon in Tcl. Type a command: |
||
Line 11: | Line 11: | ||
i(nventory) : get told what you have |
i(nventory) : get told what you have |
||
For going up, you also need a ladder."} |
For going up, you also need a ladder."} |
||
proc main argv { |
proc main argv { |
||
Room 0,0,0 StartRoom sledge |
Room 0,0,0 StartRoom sledge |
||
Line 30: | Line 31: | ||
} |
} |
||
} |
} |
||
proc Room {xyz {name {}} {items {}}} { #-- "constructor" |
proc Room {xyz {name {}} {items {}}} { #-- "constructor" |
||
if {$name eq ""} {set name R.[incr ::R()]} |
if {$name eq ""} {set name R.[incr ::R()]} |
||
if ![llength $items] {set items [lpick {sledge {} ladder gold}]} |
if {![llength $items]} {set items [lpick {sledge {} ladder gold}]} |
||
array set ::R [list $xyz.name $name $xyz.items $items $xyz.exits {}] |
array set ::R [list $xyz.name $name $xyz.items $items $xyz.exits {}] |
||
} |
} |
||
proc Inverse where { |
proc Inverse where { |
||
switch -- $where { |
switch -- $where { |
||
Line 43: | Line 46: | ||
} |
} |
||
} |
} |
||
proc Normalize where { |
proc Normalize where { |
||
switch -- $where { |
switch -- $where { |
||
Line 50: | Line 54: | ||
} |
} |
||
} |
} |
||
proc attack where { |
proc attack where { |
||
if {"sledge" ni $::Self(items)} {return "need sledge to attack!"} |
if {"sledge" ni $::Self(items)} {return "need sledge to attack!"} |
||
Line 66: | Line 71: | ||
describe |
describe |
||
} |
} |
||
proc describe {} { |
proc describe {} { |
||
set xyz $::Self(coords) |
set xyz $::Self(coords) |
||
Line 76: | Line 82: | ||
} |
} |
||
set exits $::R($xyz.exits) |
set exits $::R($xyz.exits) |
||
if ![llength $exits] {set exits nowhere} |
if {![llength $exits]} {set exits nowhere} |
||
puts "There are exits towards: [join $exits {, }]" |
puts "There are exits towards: [join $exits {, }]" |
||
inventory |
inventory |
||
} |
} |
||
proc drop what { |
proc drop what { |
||
set xyz $::Self(coords) |
set xyz $::Self(coords) |
||
Line 90: | Line 97: | ||
inventory |
inventory |
||
} |
} |
||
proc go {where {describe 1}} { |
proc go {where {describe 1}} { |
||
set where [Normalize $where] |
set where [Normalize $where] |
||
Line 105: | Line 113: | ||
} |
} |
||
set xyz $x,$y,$z |
set xyz $x,$y,$z |
||
if ![info exists ::R($xyz.name)] {Room $xyz} |
if {![info exists ::R($xyz.name)]} {Room $xyz} |
||
set ::Self(coords) $xyz |
set ::Self(coords) $xyz |
||
if $describe describe |
if {$describe} describe |
||
} |
} |
||
proc inventory {} { |
proc inventory {} { |
||
return "You have [pretty $::Self(items)]." |
return "You have [pretty $::Self(items)]." |
||
} |
} |
||
proc name what { |
proc name what { |
||
set ::R($::Self(coords).name) $what |
set ::R($::Self(coords).name) $what |
||
return "This room is now named $what." |
return "This room is now named $what." |
||
} |
} |
||
proc take what { |
proc take what { |
||
set xyz $::Self(coords) |
set xyz $::Self(coords) |
||
Line 126: | Line 137: | ||
inventory |
inventory |
||
} |
} |
||
#--- general utilities |
#--- general utilities |
||
proc alias {new = args} {interp alias {} $new {} {*}$args} |
proc alias {new = args} {interp alias {} $new {} {*}$args} |
||
Line 136: | Line 148: | ||
} |
} |
||
proc pretty lst { |
proc pretty lst { |
||
if ![llength $lst] {return nothing} |
if {![llength $lst]} {return nothing} |
||
foreach i $lst {lappend tmp "a $i"} |
foreach i $lst {lappend tmp "a $i"} |
||
regsub {(.+),} [join $tmp ", "] {\1, and} |
regsub {(.+),} [join $tmp ", "] {\1, and} |
||
} |
} |
||
main $argv |
main $argv</syntaxhighlight> |
||
</lang> |
|||
==Alternative Version== |
|||
The following version is functionally identical, but uses a setter/getter function "@" to hide away the data representation |
|||
from most of the code (except in the definition of "@" itself). |
|||
Examples: |
|||
@ my coords $x,$y,$z ;#-- modify an "instance variable" |
|||
set items [@ my items] ;#-- items I carry |
|||
set items [@ here items] ;#-- items in the current room |
|||
set items [@ $x,$y,$z items] ;#-- items in the given room |
|||
lappend [@ my items &] teacup ;#-- returns a reference |
|||
<syntaxhighlight lang="tcl">proc help args { |
|||
return "RosettaCode 3D single-user dungeon in Tcl. Type a command: |
|||
e(ast), s(outh), n(orth), w(est), u(p), d(own) |
|||
t(ake) something|all, drop something|all |
|||
a(ttack) direction: to break a wall (needs a sledge) |
|||
d(escribe): get told where you are |
|||
help: get this message |
|||
i(nventory): get told what you have |
|||
name something: give the current room another name |
|||
For going up, you also need a ladder."} |
|||
proc main argv { |
|||
Room 0,0,0 StartRoom sledge |
|||
Room 1,1,5 PrizeRoom {gold gold gold} |
|||
@ my coords 0,0,0 |
|||
@ my items {} |
|||
foreach i {east west north south up down} { |
|||
alias $i = go $i |
|||
alias [string index $i 0] = $i |
|||
} |
|||
foreach {new old} {a attack d describe i inventory t take} { |
|||
alias $new = $old |
|||
} |
|||
puts [help] |
|||
describe |
|||
while 1 { #-- REPL: Read-Eval-Print Loop |
|||
puts -nonewline "> "; flush stdout |
|||
catch [gets stdin] res |
|||
if {$res ne ""} {puts $res} |
|||
} |
|||
} |
|||
proc Room {xyz {name {}} {items {}}} { #-- "constructor" |
|||
if {$name eq ""} {set name R.[incr ::ID]} |
|||
if {$items eq {}} {set items [lpick {sledge {} ladder gold}]} |
|||
@ $xyz name $name |
|||
@ $xyz items $items |
|||
@ $xyz exits {} |
|||
} |
|||
proc Inverse where { |
|||
switch -- $where { |
|||
east {I west} west {I east} |
|||
north {I south} south {I north} |
|||
up {I down} down {I up} |
|||
default {error "No inverse defined for $where"} |
|||
} |
|||
} |
|||
proc Normalize where { |
|||
switch -- $where { |
|||
e {I east} w {I west} n {I north} s {I south} u {I up} d {I down} |
|||
default {I $where} |
|||
} |
|||
} |
|||
proc @ {coords what {value --}} { #-- universal setter/getter |
|||
if {$coords eq "my"} { |
|||
if {$value eq "--"} {return $::Self($what)} |
|||
return [expr {$value eq "&"? "::Self($what)" : [set ::Self($what) $value]}] |
|||
} |
|||
if {$coords eq "here"} {set coords $::Self(coords)} |
|||
if {$value eq "&"} {return ::R($coords.$what)} ;# reference |
|||
if {$value eq "--"} { |
|||
set ::R($coords.$what) |
|||
} else {set ::R($coords.$what) $value} |
|||
} |
|||
#------------------- commands in Afferbeck Lauder |
|||
proc attack where { |
|||
set where [Normalize $where] |
|||
set coords [@ my coords] |
|||
if {$where in [@ $coords exits]} { |
|||
puts "No need to attack $where, the road is open." |
|||
return [go $where] |
|||
} elseif {"sledge" ni [@ my items]} { |
|||
return "You can't attack without a sledge." |
|||
} |
|||
if {$where eq "up"} { |
|||
if {"ladder" ni [@ $coords items]} { |
|||
return "You can't go up without a ladder." |
|||
} |
|||
} |
|||
lappend [@ here exits &] $where |
|||
go $where 0 ;#-- describe later |
|||
lappend [@ here exits &] [Inverse $where] |
|||
describe |
|||
} |
|||
proc describe {} { |
|||
set coords [@ my coords] |
|||
set name [@ here name] |
|||
puts "You are in $name ($coords). You see [pretty [@ here items]]." |
|||
if {$name eq "PrizeRoom"} { |
|||
puts "Congratulations -- You Won!!!"; exit |
|||
} |
|||
set exits [@ here exits] |
|||
if {![llength $exits]} {set exits nowhere} |
|||
puts "There are exits towards: [join $exits {, }]." |
|||
inventory |
|||
} |
|||
proc drop what { |
|||
if {$what eq "all"} {set what [@ my items]} |
|||
foreach i $what { |
|||
if {$i ni [@ my items]} {return "You don't have a $i."} |
|||
lremove [@ my items &] $i |
|||
lappend [@ here items &] $i |
|||
} |
|||
inventory |
|||
} |
|||
proc go {where {describe 1}} { |
|||
set where [Normalize $where] |
|||
foreach {x y z} [split [@ my coords] ,] break |
|||
switch -- $where { |
|||
east {incr x} west {incr x -1} |
|||
north {incr y} south {incr y -1} |
|||
up {incr z} down {incr z -1} |
|||
default {return "usage: go (east|west|north|south|up|down)"} |
|||
} |
|||
set coords $x,$y,$z |
|||
if {$where eq "up" && "ladder" ni [@ here items]} { |
|||
return "You can't go up without a ladder." |
|||
} |
|||
if {$where ni [@ here exits]} { |
|||
return "No exit towards $where, consider an attack..." |
|||
} |
|||
if {[catch {@ $coords name}]} {Room $coords} |
|||
@ my coords $coords |
|||
if {$describe} describe |
|||
} |
|||
proc inventory {} {return "You have [pretty [@ my items]]."} |
|||
proc name what { |
|||
return "This room is now named [@ here name $what]." |
|||
} |
|||
proc take what { |
|||
if {$what eq "all"} {set what [@ here items]} |
|||
foreach i $what { |
|||
if {$i ni [@ here items]} {return "There is no $i here."} |
|||
lremove [@ here items &] $i |
|||
lappend [@ my items &] $i |
|||
} |
|||
inventory |
|||
} |
|||
#----------------------- general utilities |
|||
proc alias {new = args} {interp alias {} $new {} {*}$args} |
|||
proc I x {return $x} ;#-- Identity: simple but useful |
|||
proc lpick lst {lindex $lst [expr {int(rand()*[llength $lst])}]} |
|||
proc lremove {_lst what} { |
|||
upvar 1 $_lst lst |
|||
set pos [lsearch -exact $lst $what] |
|||
set lst [lreplace $lst $pos $pos] |
|||
} |
|||
proc pretty lst { |
|||
if {![llength $lst]} {return nothing} |
|||
foreach i $lst {lappend tmp [expr {$i eq "gold"? $i : "a $i"}]} |
|||
regsub {(.+),} [join $tmp ", "] {\1, and} |
|||
} |
|||
main $argv</syntaxhighlight> |
Latest revision as of 13:04, 30 August 2022
RCRPG/Tcl is part of RCRPG. You may find other members of RCRPG at Category:RCRPG.
This Tcl version of RCRPG was typed and tested on a cellphone, so pardon my brevity.
#!/usr/bin/env tclsh
proc help args {
return "RosettaCode 3D single user dungeon in Tcl. Type a command:
e(ast), w(est), n(orth), s(outh), u(p), d(own)
t(ake) sth|all, drop sth|all
a(ttack) direction: to break a hole in the wall (needs sledge)
describe : get told where you are
i(nventory) : get told what you have
For going up, you also need a ladder."}
proc main argv {
Room 0,0,0 StartRoom sledge
Room 1,1,5 PrizeRoom {gold gold gold}
array set ::Self {coords 0,0,0 items {}}
foreach i {east west north south up down} {
alias $i = go $i
alias [string index $i 0] = go $i
}
foreach {new old} {a attack i inventory t take} {
alias $new = $old
}
puts [help]
describe
while 1 { #-- Read-Eval-Print loop
puts -nonewline "> "; flush stdout
catch [gets stdin] res
if {$res ne ""} {puts $res}
}
}
proc Room {xyz {name {}} {items {}}} { #-- "constructor"
if {$name eq ""} {set name R.[incr ::R()]}
if {![llength $items]} {set items [lpick {sledge {} ladder gold}]}
array set ::R [list $xyz.name $name $xyz.items $items $xyz.exits {}]
}
proc Inverse where {
switch -- $where {
east {I west} west {I east}
north {I south} south {I north}
up {I down} down {I up}
default {error "bad direction $where"}
}
}
proc Normalize where {
switch -- $where {
e {I east} w {I west} n {I north} s {I south}
u {I up} d {I down}
default {I $where}
}
}
proc attack where {
if {"sledge" ni $::Self(items)} {return "need sledge to attack!"}
set where [Normalize $where]
set xyz $::Self(coords)
if {$where in $::R($xyz.exits)} {
puts "No need to attack.."
return [go $where]
}
if {$where eq "up" && "ladder" ni $::R($xyz.items)} {
return "You can't go up without a ladder."
}
lappend ::R($xyz.exits) $where
go $where 0
lappend ::R($::Self(coords).exits) [Inverse $where]
describe
}
proc describe {} {
set xyz $::Self(coords)
set name $::R($xyz.name)
set items [pretty $::R($xyz.items)]
puts "You are in $name ($xyz) and see $items."
if {$name eq "PrizeRoom"} {
puts "Congratulations - you won!"
exit
}
set exits $::R($xyz.exits)
if {![llength $exits]} {set exits nowhere}
puts "There are exits towards: [join $exits {, }]"
inventory
}
proc drop what {
set xyz $::Self(coords)
if {$what eq "all"} {set what $::Self(items)}
foreach i $what {
if {$i ni $::Self(items)} {return "You don't carry a $i."}
lremove ::Self(items) $i
lappend ::R($xyz.items) $i
}
inventory
}
proc go {where {describe 1}} {
set where [Normalize $where]
if {$where ni $::R($::Self(coords).exits)} {
return "No exit $where, consider an attack."
}
if {$where eq "up" && "ladder" ni $::R($::Self(coords).items)} {
return "You can't go up without a ladder."
}
foreach {x y z} [split $::Self(coords) ,] break
switch -- $where {
east {incr x} west {incr x -1}
north {incr y} south {incr y -1}
up {incr z} down {incr z -1}
}
set xyz $x,$y,$z
if {![info exists ::R($xyz.name)]} {Room $xyz}
set ::Self(coords) $xyz
if {$describe} describe
}
proc inventory {} {
return "You have [pretty $::Self(items)]."
}
proc name what {
set ::R($::Self(coords).name) $what
return "This room is now named $what."
}
proc take what {
set xyz $::Self(coords)
if {$what eq "all"} {set what $::R($xyz.items)}
foreach i $what {
if {$i ni $::R($xyz.items)} {return "There is no $i here."}
lremove ::R($xyz.items) $i
lappend ::Self(items) $i
}
inventory
}
#--- general utilities
proc alias {new = args} {interp alias {} $new {} {*}$args}
proc I x {return $x} ;# identity
proc lpick lst {lindex $lst [expr {int(rand()*[llength $lst])}]}
proc lremove {_lst what} {
upvar 1 $_lst lst
set pos [lsearch -exact $lst $what]
set lst [lreplace $lst $pos $pos]
}
proc pretty lst {
if {![llength $lst]} {return nothing}
foreach i $lst {lappend tmp "a $i"}
regsub {(.+),} [join $tmp ", "] {\1, and}
}
main $argv
Alternative Version
The following version is functionally identical, but uses a setter/getter function "@" to hide away the data representation from most of the code (except in the definition of "@" itself). Examples:
@ my coords $x,$y,$z ;#-- modify an "instance variable" set items [@ my items] ;#-- items I carry set items [@ here items] ;#-- items in the current room set items [@ $x,$y,$z items] ;#-- items in the given room lappend [@ my items &] teacup ;#-- returns a reference
proc help args {
return "RosettaCode 3D single-user dungeon in Tcl. Type a command:
e(ast), s(outh), n(orth), w(est), u(p), d(own)
t(ake) something|all, drop something|all
a(ttack) direction: to break a wall (needs a sledge)
d(escribe): get told where you are
help: get this message
i(nventory): get told what you have
name something: give the current room another name
For going up, you also need a ladder."}
proc main argv {
Room 0,0,0 StartRoom sledge
Room 1,1,5 PrizeRoom {gold gold gold}
@ my coords 0,0,0
@ my items {}
foreach i {east west north south up down} {
alias $i = go $i
alias [string index $i 0] = $i
}
foreach {new old} {a attack d describe i inventory t take} {
alias $new = $old
}
puts [help]
describe
while 1 { #-- REPL: Read-Eval-Print Loop
puts -nonewline "> "; flush stdout
catch [gets stdin] res
if {$res ne ""} {puts $res}
}
}
proc Room {xyz {name {}} {items {}}} { #-- "constructor"
if {$name eq ""} {set name R.[incr ::ID]}
if {$items eq {}} {set items [lpick {sledge {} ladder gold}]}
@ $xyz name $name
@ $xyz items $items
@ $xyz exits {}
}
proc Inverse where {
switch -- $where {
east {I west} west {I east}
north {I south} south {I north}
up {I down} down {I up}
default {error "No inverse defined for $where"}
}
}
proc Normalize where {
switch -- $where {
e {I east} w {I west} n {I north} s {I south} u {I up} d {I down}
default {I $where}
}
}
proc @ {coords what {value --}} { #-- universal setter/getter
if {$coords eq "my"} {
if {$value eq "--"} {return $::Self($what)}
return [expr {$value eq "&"? "::Self($what)" : [set ::Self($what) $value]}]
}
if {$coords eq "here"} {set coords $::Self(coords)}
if {$value eq "&"} {return ::R($coords.$what)} ;# reference
if {$value eq "--"} {
set ::R($coords.$what)
} else {set ::R($coords.$what) $value}
}
#------------------- commands in Afferbeck Lauder
proc attack where {
set where [Normalize $where]
set coords [@ my coords]
if {$where in [@ $coords exits]} {
puts "No need to attack $where, the road is open."
return [go $where]
} elseif {"sledge" ni [@ my items]} {
return "You can't attack without a sledge."
}
if {$where eq "up"} {
if {"ladder" ni [@ $coords items]} {
return "You can't go up without a ladder."
}
}
lappend [@ here exits &] $where
go $where 0 ;#-- describe later
lappend [@ here exits &] [Inverse $where]
describe
}
proc describe {} {
set coords [@ my coords]
set name [@ here name]
puts "You are in $name ($coords). You see [pretty [@ here items]]."
if {$name eq "PrizeRoom"} {
puts "Congratulations -- You Won!!!"; exit
}
set exits [@ here exits]
if {![llength $exits]} {set exits nowhere}
puts "There are exits towards: [join $exits {, }]."
inventory
}
proc drop what {
if {$what eq "all"} {set what [@ my items]}
foreach i $what {
if {$i ni [@ my items]} {return "You don't have a $i."}
lremove [@ my items &] $i
lappend [@ here items &] $i
}
inventory
}
proc go {where {describe 1}} {
set where [Normalize $where]
foreach {x y z} [split [@ my coords] ,] break
switch -- $where {
east {incr x} west {incr x -1}
north {incr y} south {incr y -1}
up {incr z} down {incr z -1}
default {return "usage: go (east|west|north|south|up|down)"}
}
set coords $x,$y,$z
if {$where eq "up" && "ladder" ni [@ here items]} {
return "You can't go up without a ladder."
}
if {$where ni [@ here exits]} {
return "No exit towards $where, consider an attack..."
}
if {[catch {@ $coords name}]} {Room $coords}
@ my coords $coords
if {$describe} describe
}
proc inventory {} {return "You have [pretty [@ my items]]."}
proc name what {
return "This room is now named [@ here name $what]."
}
proc take what {
if {$what eq "all"} {set what [@ here items]}
foreach i $what {
if {$i ni [@ here items]} {return "There is no $i here."}
lremove [@ here items &] $i
lappend [@ my items &] $i
}
inventory
}
#----------------------- general utilities
proc alias {new = args} {interp alias {} $new {} {*}$args}
proc I x {return $x} ;#-- Identity: simple but useful
proc lpick lst {lindex $lst [expr {int(rand()*[llength $lst])}]}
proc lremove {_lst what} {
upvar 1 $_lst lst
set pos [lsearch -exact $lst $what]
set lst [lreplace $lst $pos $pos]
}
proc pretty lst {
if {![llength $lst]} {return nothing}
foreach i $lst {lappend tmp [expr {$i eq "gold"? $i : "a $i"}]}
regsub {(.+),} [join $tmp ", "] {\1, and}
}
main $argv