File: features.tcl

package info (click to toggle)
deal 3.1.9-12
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, sid
  • size: 1,552 kB
  • sloc: ansic: 5,224; cpp: 4,186; tcl: 3,125; makefile: 200; sh: 10
file content (210 lines) | stat: -rw-r--r-- 5,523 bytes parent folder | download | duplicates (4)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
#
# deal.tcl - this file is sourced at startup by Deal 3.0 or later
#
# Copyright (C) 1996-2001, Thomas Andrews
#
# $Id: features.tcl 328 2010-02-23 23:48:06Z thomasoa $
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#

proc dds_reset_command {} {
  dds_reset
  deal_reset_cmds [list dds_reset_command]
}


namespace eval deal {

    variable metadata
    variable unicode 1

    #
    # Put data in the cache, to be unset at next call
    # to deal_deck
    #
    proc metadata {name code} {
	variable metadata
	if {![info exists metadata($name)]} {
	    if {[catch {set metadata($name) [uplevel $code]}]} {
		global errorInfo
		puts stderr "Error: $errorInfo"
	    } else {
		deal_reset_cmds [list unset ::deal::metadata($name)]
	    }
	}
	return $metadata($name)
    }

    proc loop {} {
	next
	write
    }


    proc input {format args} {
	uplevel #0 [list source "/usr/share/deal/input/$format.tcl" ]
	set command [list "${format}::set_input"]
	foreach arg $args {
	    lappend command $arg
	}
	uplevel #0 $command
    }

    proc debug {args} {
       puts stderr $args
    }

    # Cause an error if any hand stacking has occured
    proc nostacking {} {
        set format [uplevel {namespace current}]
        proc ::stack_hand {args} \
		"error \"No hand stacking with input format $format\""
        proc ::stack_cards {args} \
		"error \"No card stacking with input format $format\""
        foreach hand {south north east west} {
          foreach holding [stacked $hand] {
             if {[holding length $holding]!=0} {
                error "Stacking cards is not consistent with input format $format"
             }
          }
        }
    }
}

# These two routines used to be defined in C, but it's better for them
# to fit the pattern of shape functions.

if {[string equal [info commands dds_reset] "dds_reset"]} {
  dds_reset_command
}

shapecond balanced {($h<5)&&($s<5)&&($s*$s+$h*$h+$d*$d+$c*$c)<=47}
shapecond semibalanced {$h<=5&&$s<=5&&$d<=6&&$c<=6&&$c>=2&&$d>=2&&$h>=2&&$s>=2}
shapecond AnyShape {1}

#
#  The three routines, joinclass, negateclass, intersectclass, used to be
#  implemented in C, but were never documented and recently crashed Deal 3.0.x
#  when called.  I've reimplemented them here in pure Tcl.
#
proc joinclass {newclass args} {
    set values [list 0]
    foreach class $args {
	lappend values "\[$class eval \$s \$h \$d \$c\]"
    }

    shapecond ___tempclass [join $values "||"]

    # make sure it is compiled first - use temporary name
    # in case we are re-using an old name for a class
    ___tempclass eval 13 0 0 0
    rename ___tempclass $newclass
}

proc negateclass {newclass class} {
    shapecond ___tempclass "!\[$class eval \$s \$h \$d \$c\]"
    ___tempclass eval 13 0 0 0
    rename ___tempclass $newclass
}

proc intersectclass {newclass args} {

    set values [list 1]
    foreach class $args {
	lappend values "\[$class eval \$s \$h \$d \$c\]"
    }
    shapecond ___tempclass [join $values "&&"]
    ___tempclass eval 13 0 0 0
    rename ___tempclass $newclass
}

namespace eval deal {

    variable tricksCmd ::tricks
    variable tricksCache "tricks"

    #
    # "tricks" - Determine the number of tricks declarer can
    # make in the denomination given.
    #
    proc tricks {declarer denom} {
	variable tricksCmd
	variable tricksCache
	::deal::metadata "$tricksCache.$declarer.$denom" [list $tricksCmd $declarer $denom]
    }

}

#
# Returns all of the hands in a list
#
proc full_deal {} {
  return [list [north] [east] [south] [west]]
}


#
# This is based on a contribution from Rex Livingston, who supplied
# me with a C version of this routine.
# It implements the New Losing Trick Count, which can be seen described on
# Wikipedia at: 
#
#   http://en.wikipedia.org/wiki/Losing_trick_count#New_Losing_Trick_Count
#
# This is much like a 321-count in many ways.
# As with the 'losers' function, it actually returns integer values, so
# it returns 'half losers.'
#
holdingProc newLTC {A K Q J T length} {

  if {$length==0} { return 0 }

  set halflosers 0
  if {!$A} { incr halflosers 3 }
  if {$length>1 && !$K} { incr halflosers 2}
  if {$length>2} {
    if {!$Q} {
      incr halflosers 1
    }
  }
  return $halflosers
}

holdingProc zero {length} {
  return 0
}

proc patternclass {name code} {
   namespace eval ::pattern "proc $name {l1 l2 l3 l4} {$code}"
   
   set shapecode {
     set sorted [lsort -integer -decreasing [list $s $h $d $c]]
   }
   shapeclass $name "$shapecode\n eval ::pattern::$name \$sorted"
}

proc patternfunc {name code} {
   namespace eval ::pattern "proc $name {l1 l2 l3 l4} {$code}"
   
   set shapecode {
     set sorted [lsort -integer -decreasing [list $s $h $d $c]]
   }
   shapefunc $name "$shapecode\n eval ::pattern::$name \$sorted"
}

proc patterncond {name expr} {
    patternclass $name "if {$expr} { return 1} else {return 0}"
}