RCRPG/Tcl

RCRPG/Tcl is part of RCRPG. You may find other members of RCRPG at Category:RCRPG.

This version of RCRPG was typed and tested on a cellphone, so pardon my brevity.

<lang Tcl>

1. !/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

}

1. --- 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 </lang>