Your IP : 216.73.216.224
###############################################################################
# Deal or No Deal version 1.0 #
# Copyright 2011 Steve Church (rojo on EFnet). All rights reserved. #
# #
# IRC adaptation of the television game show Deal or No Deal. The game is #
# played via DCC, allows concurrent running games, and features bleeding-edge #
# 1980's ascii art graphics. A video adapter with at least 64K RAM is #
# recommended. :) #
# #
# Choose a case to begin the game. This case is not opened until the end of #
# the game. Then eliminate the remaining cases containing varying amounts of #
# money, either winning the most possible money, or at least selling your #
# case to the banker for more than it is worth. See the Wikipedia article at #
# http://en.wikipedia.org/wiki/Deal_or_no_deal for full details. #
# #
# To start a game, type !deal in a channel or /msg bot !deal. The bot will #
# initiate a DCC chat with the user to serve the game. This chat session is #
# separate from the partyline, and does not require +p access. #
# #
# If the girls look weird, configure your IRC client to use a monospace / #
# console font (Lucida Console / Bitstream Vera Sans Mono / etc.) #
# #
# Please report bugs to rojo on EFnet. #
# #
# License #
# #
# Redistribution and use in source and binary forms, with or without #
# modification, are permitted provided that the following conditions are met: #
# #
# 1. Redistributions of source code must retain the above copyright notice, #
# this list of conditions and the following disclaimer. #
# #
# 2. Redistributions in binary form must reproduce the above copyright #
# notice, this list of conditions and the following disclaimer in the #
# documentation and/or other materials provided with the distribution. #
# #
# THIS SOFTWARE IS PROVIDED BY STEVE CHURCH "AS IS" AND ANY EXPRESS OR #
# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES #
# OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN #
# NO EVENT SHALL STEVE CHURCH OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, #
# INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES #
# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR #
# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER #
# CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT #
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY #
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH #
# DAMAGE. #
###############################################################################
namespace eval dond-dcc {
set settings(listen-port) 6999 ;# pick a port on which your bot can receive connections
set settings(idle-timeout) 900 ;# disconnect users idle this many seconds
set settings(connect-timeout) 180 ;# abort listening for connections if no connect in this many secs
set settings(trigger) {!deal !dond} ;# the trigger to get the bot to initiate a game
set settings(currency-symbol) {$} ;# dollars / pounds / euros / yen / etc
set settings(number-group-symbol) {,} ;# $1,000 / �1.000
set settings(number-decimal-symbol) {.} ;# $0.01 / �0,01
#########################
# end of user variables #
#########################
variable scriptver 1.0
variable ns [namespace current]
variable settings
variable connect_queue
variable server_idx
proc connected {idx addr port} {
variable ns; variable connect_queue
fileevent $idx readable [list ${ns}::evt $idx $addr $port]
fconfigure $idx -buffering line -blocking 0
incr connect_queue -1
if {!$connect_queue} { timeout_connect 0 }
putlog "Connected and serving game to $addr"
if {[catch { ::dond-game::start $idx } err]} { puts $idx $err }
}
proc evt {idx addr port} {
variable settings
if {[eof $idx] || [catch {gets $idx line} res] || [regexp -nocase {^(quit|exit|die|bye|stfu|shut.*up)$} $line]} {
puts $idx "OK, bye."
timeout_chat $idx 0 $addr
return
}
if {$res > -1} {
timeout_chat $idx $settings(idle-timeout) $addr
::dond-game::input_handler $idx $line
}
}
proc timeout_chat {idx secs addr} {
variable settings; variable ns
foreach t [utimers] {
if {[string equal [lindex [lindex $t 1] 1] $idx]} { killutimer [lindex $t 2] }
}
utimer $secs [list ${ns}::close_session $idx $addr]
}
proc close_session {idx addr} {
close $idx
putlog "$addr has disconnected from Deal or No Deal."
}
proc timeout_connect {secs} {
variable settings; variable ns
foreach t [utimers] {
if {[string equal [lindex $t 1] ${ns}::close_server]} { killutimer [lindex $t 2] }
}
utimer $secs ${ns}::close_server
}
proc close_server {} {
variable connect_queue 0; variable server_idx
close $server_idx
set server_idx 0
}
proc chatrequest {nick uhost hand args} {
variable settings; variable connect_queue; variable server_idx; variable ns
if {![info exists server_idx] || ![string length $server_idx]} { variable server_idx 0 }
set longip [longip $settings(ip)]
if {[string match "#*" [lindex $args 0]]} { set dest [lindex $args 0] } { set dest $nick }
if {[string match -nocase "mibbit*" $uhost]} {
puthelp "PRIVMSG $dest :Sorry $nick, but I run Deal or No Deal via DCC Chat. Web\
chats don't support direct client-client connections."
return
}
putquick "PRIVMSG $dest :$nick: I'm ready to play. Accept this DCC chat request."
putquick "PRIVMSG $nick :\001DCC CHAT chat $longip $settings(listen-port)\001"
timeout_connect $settings(connect-timeout)
if {[incr connect_queue] == 1} {
variable server_idx [socket -server ${ns}::connected $settings(listen-port)]
fconfigure $server_idx -blocking 0
}
putlog "Sending Deal or No Deal chat request to $nick...."
}
proc update_vhost4 {ip host status} {
global vhost4 version
if {!$status} {
set ver [split $version .]
set ver [lindex $ver 0][lindex $ver 1]
if {[expr {$ver - 18}] < 1} { set v4label my-ip } { set v4label vhost4 }
putlog "Deal or No Deal unable to determine a listen IP. DNS lookup of\
$host failed. Try setting nat-ip or $v4label in your bot's conf file."
return
}
set vhost4 $ip
init
}
proc init {} {
global {nat-ip} {my-ip} vhost4 botnick botname version
variable settings; variable ns; variable scriptver
if {![info exists settings(ip)] || ![regexp {^([0-9]+\.){3}[0-9]+$} $settings(ip)]} {
if {[regexp {^([0-9]+\.){3}[0-9]+$} ${nat-ip}]} {
set settings(ip) ${nat-ip}
} elseif {[regexp {^([0-9]+\.){3}[0-9]+$} $vhost4]} {
set settings(ip) $vhost4
} elseif {[regexp {^([0-9]+\.){3}[0-9]+$} ${my-ip}]} {
set settings(ip) ${my-ip}
} else {
dnslookup [lindex [split $botname @] 1] ${ns}::update_vhost4
return
}
}
foreach trigger $settings(trigger) {
bind pub - $trigger ${ns}::chatrequest
bind msg - $trigger ${ns}::chatrequest
}
putlog "Deal or No Deal $scriptver loaded. Chats will be bound to $settings(ip):$settings(listen-port)."
}
proc longip {ip} {
set ip [split $ip .]
if {[catch {
set res 0
for {set i 0} {$i < 4} {incr i} {
incr res [expr {[lindex $ip $i] * int(pow(256, 3 - $i))}]
}
}]} { return 0 } { return $res }
}
init
}; # end namespace
namespace eval dond-game {
variable ns [namespace current]
array set settings [array get ::dond-dcc::settings]
variable settings
array set values [list]
set values(default) {
0.01
1
5
10
25
50
75
100
200
300
400
500
750
1000
5000
10000
25000
50000
75000
100000
200000
300000
400000
500000
750000
1000000
}
variable values
variable girl {
{% .-. }
{% ($/%^$\%) }
{% ($\&=$/%) }
{$ .-'-. }
{$/($#_$c#_$)\$}
{$\\#) ($//}
{}
{# / \ }
{# \___/ }
{$ \|/ }
{$ /|\ }
{$ \|/ }
{# /Y\ }
{}
}
variable closed {
{&14,01 u ,--, u &}
{&14,01[&14,15==========&14,01]&}
{&14,01[&01,15#&14,01]&}
{&14,01[&14,15u==========u&14,01]&}
}
variable opened {
{&14,01 __________ &}
{&14,01 |&14,04 &14,01| &}
{&14,01 |&00,01D&14,01| &}
{&14,01 |&14,04u u&14,01| &}
{&14,01/____________&14,01\&}
{&14,01[&14,15u ;..; u&14,01]&}
}
# 4 and -1 are never used. They just help with rendering.
array set stage {
4 {27 28 29 30 31 32 33}
3 {21 22 23 24 25 26}
2 {14 15 16 17 18 19 20}
1 {8 9 10 11 12 13}
0 {1 2 3 4 5 6 7}
-1 {-5 -4 -3 -2 -1 0}
}
variable stage
foreach i [list active_girls g round chosen offers] {
array set $i [list]
variable $i
}
variable round
# round($idx) {x0 x1 x2}
# x0 = complete round (from 6 to 0 then 0 then 0 etc. till end)
# x1 = stage within the round (begin|cases|banker)
# x2 = iterations within the stage (open case 1 of 6, 2 of 6, etc)
proc start {idx} {
variable ns; variable active_girls; variable values; variable g; variable stage; variable round; variable offers
set values($idx) [shuffle4 [shuffle4 [shuffle4 $values(default)]]]
set active_girls($idx) [list]
set offers($idx) [list]
set round($idx) [list 6 begin 0]
foreach {step numbers} [array get stage] {
for {set i [lindex $numbers 0]} {$i <= [lindex $numbers end]} {incr i} {
set template [getgirl $i]
set g($idx:$i:top) [lrange $template 0 6]
set g($idx:$i:bottom) [lrange $template 7 end]
if {$step >= 0 && $step <= 3} { lappend active_girls($idx) $i }
}
}
puts $idx "The stage:"
if {[catch {draw_stage $idx} err]} { foreach line [split $err \n] {puts $idx $line} }
puts $idx ""
puts $idx "Choose a case (1 - 26). This case will not be opened until the end of the game."
}
proc test {idx} {
variable g; variable active_girls; variable values
foreach chick $active_girls($idx) {
set val [lindex $values($idx) [expr {$chick - 1}]]
if {$val >= 100000} {
set g($idx:$chick:top) [lreplace $g($idx:$chick:top) end end [stage_cell [monetize $val]]]
}
}
draw_stage $idx
}
proc input_handler {idx line} {
variable round
if {[catch {
switch -glob -nocase $line {
*board* { draw_board $idx }
*stage* { draw_stage $idx }
*start* { start $idx }
*cheat* { test $idx }
default {
# round($idx) {x0 x1 x2}
# x0 = complete round
# x1 = stage within the round (open cases / banker offer)
# x2 = iterations within the stage (open case 1 of 6, 2 of 6, etc)
switch [lindex $round($idx) 1] {
begin { keepcase $idx $line }
cases { opencase $idx $line }
banker {
switch -nocase -glob $line {
*no* { nodeal $idx }
*deal* { deal $idx }
default { puts $idx "What?" }
}
}
endgame {
switch -nocase -glob $line {
*no* { endgame $idx 0 }
*yes* { endgame $idx 1 }
*keep* { endgame $idx 0 }
*trade* { endgame $idx 1 }
default { puts $idx "Sorry, I don't understand." }
}
}
default {
puts "Something went terribly wrong."
}
}
}
}
} err]} { foreach line [split $err \n] {puts $idx $line} }
}
proc draw_board {idx} {
variable values; variable settings; variable offers
for {set i 0} {$i < 13} {incr i} {
set left [lindex $values(default) $i]
if {[lsearch -exact $values($idx) $left] > -1} {
set left [board_cell [monetize [lindex $values(default) $i]]]
} { set left "\00314,01\[[string repeat { } 10]\]\00314" }
set middle [lindex $values(default) [expr {$i + 13}]]
if {[lsearch -exact $values($idx) $middle] > -1} {
set middle [board_cell [monetize [lindex $values(default) [expr {$i + 13}]]]]
} { set middle "\00314,01\[[string repeat { } 10]\]\00314" }
set right ""
set j [expr {$i - 1}]
if {[llength $offers($idx)] && $j < [llength $offers($idx)]} {
if {!$i} { set right "Previous banker offers:" } { set right "$i: [monetize [lindex $offers($idx) $j]]" }
set right "\00314$right\003"
}
puts $idx [string trim "$left $middle $right"]
}
}
proc draw_stage {idx} {
variable g; variable stage; variable active_girls
# x: levels of the stage
for {set x 3} {$x >= -1} {incr x -1} {
# i: number of lines in the top of a girl
for {set i 0} {$i < [llength $g($idx:$x:top)]} {incr i} {
# j: number of girls on a row of the stage
for {set j 0} {$j < [llength $stage($x)]} {incr j} {
set y [expr {$x + 1}]
set up [lindex $stage($y) $j]
set self [lindex $stage($x) $j]
if {[llength $stage($x)] > [llength $stage($y)]} {
set long true
set ur [lindex $stage($y) $j]
} {
set long false
set ul [lindex $stage($y) $j]
set ur [lindex $stage($y) [expr {$j + 1}]]
}
if {$j == 0} {
if {$i == 6 && [expr {$x % 2}]} {
lappend out [string repeat { } 7]
} elseif {$i < 6} {
lappend out [string repeat { } 3]
}
}
if {!$long} {
catch {
set legs [lindex $g($idx:$up:bottom) $i]
if {[lsearch -exact $active_girls($idx) $ul] > -1} {
lappend out $legs
} { lappend out [string repeat { } [string length [strip $legs]]] }
}
}
catch {
set torso [lindex $g($idx:$self:top) $i]
if {[lsearch -exact $active_girls($idx) $self] > -1} {
lappend out $torso
} { lappend out [string repeat { } [string length [strip $torso]]] }
}
if {$long || $j == [expr {[llength $stage($x)] - 1}] && [incr up]} {
catch {
set legs [lindex $g($idx:$up:bottom) $i]
if {[lsearch -exact $active_girls($idx) $ur] > -1} {
lappend out $legs
} { lappend out [string repeat { } [string length [strip $legs]]] }
}
}
if {$i == 6} { lappend out " " }
}; # end for j
if {[string length [string trim [join $out]]]} {
puts $idx [string trimright [join $out {}]]
}
set out [list]
}; # end for i
}
}
proc getgirl {txt} {
variable girl
set lips "\003[lindex [list 04 06 13] [rand 3]],01"
set skin "\003[lindex [list 08 08 08 08 08 08 08 08 08 05] [rand 10]],01"
if {$skin == "\00305,01"} {
set hair "\00314,01"
} else {
set hair "\003[lindex [list 04 05 05 05 05 05 07 08 08 08 08 08 14 14 14 14 14] [rand 17]],01"
}
set cleavage "[lindex [list I Y] [rand 2]]"
set dress "\00314,01"
set ret [list]
for {set i 0} {$i < [llength $girl]} {incr i} {
set girlpart [string map "% $hair \$ $skin \# $dress \& $lips c $cleavage" [lindex $girl $i]]
if {$i == 6} { lappend ret [stage_cell $txt] } { lappend ret $girlpart }
}
return $ret
}
proc keepcase {idx num} {
variable closed; variable values; variable active_girls; variable round; variable chosen
if {[set ag [lsearch -exact $active_girls($idx) $num]] == -1} {
draw_stage $idx
puts $idx "Enter a number from 1 to 26."
return
}
set chosen($idx) [list $num [lindex $values($idx) [expr {$num - 1}]]]
set active_girls($idx) [lreplace $active_girls($idx) $ag $ag]
puts $idx "The board:"
draw_board $idx
puts $idx ""
puts $idx "The stage:"
draw_stage $idx
puts $idx ""
puts $idx "The briefcase you have chosen is yours to keep. You win however\
much money it contains. It could contain any of the values you see on the\
board. During each round, you must open the remaining cases to determine, by\
process of elimination, which case you originally chose. Along the way, the\
banker will try to minimize his losses by offering to buy your case from you. \
At the end, you will be given the option of trading your case for the last\
one remaining unopened."
foreach line $closed {
set val "[center $num 10]"
set line [string map "& \003 u \037" $line]
puts $idx [regsub {#} $line $val]
}
set round($idx) [list 6 cases 1]
puts $idx ""
set r [lindex $round($idx) 0]
if {!$r || $r == 1} { set r "1 case" } { set r "$r cases" }
puts $idx "Let's get the first round started, then. You have $r to open. Open a case."
}
proc opencase {idx num} {
variable closed; variable opened; variable values; variable active_girls; variable round
set lastround [string equal [lindex $round($idx) 1] endgame]
if {[set ag [lsearch -exact $active_girls($idx) $num]] == -1 && !$lastround} {
draw_stage $idx
puts $idx "Enter the number of one of the remaining cases."
return
}
set active_girls($idx) [lreplace $active_girls($idx) $ag $ag]
set val [lindex $values($idx) [expr {$num - 1}]]
set val "[center [monetize $val] 10]"
if {!$lastround} {
puts $idx "The stage:"
draw_stage $idx
puts $idx ""
}
for {set i 0} {$i < [llength $opened]} {incr i} {
if {$i > 3} { set line [string repeat " " 12] } { set line "" }
if {$i == 2} {
append line "[lindex $closed $i] --> [lindex $opened $i]"
set line [regsub {#} $line [center $num 10]]
set line [regsub D $line [center $val 10]]
} { append line "[lindex $closed $i] [lindex $opened $i]" }
set line [string map "& \003 u \037" $line]
puts $idx $line
}
puts $idx ""
if {$lastround} { return }
incr num -1
set values($idx) [lreplace $values($idx) $num $num {}]
set r [lindex $round($idx) 0]
set i [lindex $round($idx) 2]
if {$r <= $i} {
banker $idx
} else {
incr i
set round($idx) [list $r cases $i]
puts $idx "Choose another case ($i of $r)."
}
}
proc banker {idx} {
variable values; variable round; variable offers
set total 0
set vals 0
foreach val $values($idx) {
if {[string length $val]} {
if {![string equal $val 0.01]} { incr total $val }
incr vals
}
}
set scale [list 1 0.9 0.7 0.37 0.22 0.15 0.11]
set avg [expr {$total / $vals * [lindex $scale [lindex $round($idx) 0]]}]
set i 0
while {$avg >= [expr {pow(10,$i)}]} { incr i }
set avg [expr {round(round($avg / pow(10,$i - 2)) * pow(10,$i - 2))}]
set fudge 0
foreach val $values($idx) {
if {![string length $val]} { continue }
if {$val > $avg} { incr fudge } { incr fudge -1 }
}
set avg [expr {round($avg / 50 * $fudge) + $avg}]
lappend offers($idx) $avg
set r [lindex $round($idx) 0]
incr r -1
if {$r < 1} { set cases "1 case"; set r 0 } { set cases "$r cases" }
set round($idx) [list $r banker 1]
draw_board $idx
puts $idx ""
puts $idx "The banker offers you [monetize $avg] for your case. If you choose\
\"no deal,\" you will have $cases to open next round. Deal or no deal?"
}
proc monetize {what} {
variable settings
return "$settings(currency-symbol)[comma $what]"
}
proc nodeal {idx} {
variable round; variable chosen; variable active_girls
set round($idx) [list [lindex $round($idx) 0] cases 1]
if {[llength $active_girls($idx)] == 1} {
set round($idx) [lreplace $round($idx) 1 1 endgame]
puts ""
puts $idx "You are holding case [lindex $chosen($idx) 0]. The only remaining case is\
number [lindex $active_girls($idx) 0]. Do you wish to trade cases?"
return
}
draw_stage $idx
puts $idx ""
set r [lindex $round($idx) 0]
if {!$r || $r == 1} { set r "1 case" } { set r "$r cases" }
puts $idx "Play on then. You have $r to open. Open a case."
}
proc deal {idx} {
variable chosen; variable offers; variable round; variable values
set round($idx) [lreplace $round($idx) 1 1 endgame]
opencase $idx [lindex $chosen($idx) 0]
puts $idx "You originally chose case [lindex $chosen($idx) 0]. It contained [monetize [lindex $chosen($idx) 1]]."
if {[lindex $offers($idx) end] > [lindex $chosen($idx) 1]} {
puts $idx "You sold your case for more than it was worth, winning [monetize [lindex $offers($idx) end]]. Great game!"
} { puts $idx "You chose foolishly. Oh well. [monetize [lindex $offers($idx) end]] is better than nothing." }
if {[set val [lsearch -exact $values($idx) 1000000]] > -1 && [lindex $chosen($idx) 0] != [expr {$val + 1}]} {
incr val
opencase $idx $val
puts $idx "It was case $val that contained [monetize 1000000]. Type \002start\002 to play again."
} { puts $idx "Type \002start\002 to play again." }
}
proc endgame {idx tf} {
variable chosen; variable active_girls; variable values
set trade $active_girls($idx)
lappend active_girls($idx) [lindex $values($idx) [expr {[lindex $active_girls($idx) 0] - 1}]]
set yourcase [lindex $chosen($idx) 0]
set yourvalue [lindex $chosen($idx) 1]
set hercase [lindex $active_girls($idx) 0]
set hervalue [lindex $active_girls($idx) 1]
if {$tf} {
puts $idx "You chose to trade for case $hercase. Your case contained..."
opencase $idx $yourcase
puts $idx "That means case $hercase contains..."
opencase $idx $hercase
if {$hervalue > $yourvalue} {
puts $idx "Nice job. You won [monetize $hervalue]. Good game! Type \002start\002 to play again."
} { puts $idx "Oh well. [monetize $hervalue] is better than nothing. Type \002start\002 to play again." }
} else {
puts $idx "You chose not to trade for case $hercase. That case contained..."
opencase $idx $hercase
puts $idx "That means your case contains..."
opencase $idx $yourcase
if {$yourvalue > $hervalue} {
puts $idx "Nice job. You won [monetize $yourvalue]. Good game! Type \002start\002 to play again."
} { puts $idx "Oh well. [monetize $yourvalue] is better than nothing. Type \002start\002 to play again." }
}
}
proc strip {what} {
return [regsub -all -- {\002|\037|\026|\003(\d{1,2})?(,\d{1,2})?} $what ""]
}
proc board_cell {txt} {
return "\00307,01\[\00301,08[center $txt 10]\00307,01\]"
}
proc stage_cell {txt} {
return "\00314,01\[\00301,15[center $txt 10]\00314,01\]\003"
}
proc stage_cell_black {} {
return "\002\00300,14\[ \]\003\002"
}
proc center {txt len} {
while {[string length $txt] < $len} {
set txt " $txt "
}
if {[string length $txt] > $len} {
set txt [string range $txt 0 [expr {[string length $txt] - 2}]]
}
return $txt
}
# http://code.activestate.com/recipes/68381-add-commas-to-a-number/
proc comma {num {sep ""}} {
variable settings
if {![string length $sep]} { set sep $settings(number-group-symbol) }
if {![string equal $settings(number-decimal-symbol) .]} {
set num [string map ". $settings(number-decimal-symbol)" $num]
}
while {[regsub {^([-+]?\d+)(\d\d\d)} $num "\\1$sep\\2" num]} {}
return $num
}
# http://wiki.tcl.tk/941
proc K { x y } { set x }
proc shuffle4 { list } {
set n [llength $list]
while {$n>0} {
set j [expr {int(rand()*$n)}]
lappend slist [lindex $list $j]
incr n -1
set temp [lindex $list $n]
set list [lreplace [K $list [set list {}]] $j $j $temp]
}
return $slist
}
}; # end namespace