File: parscore.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 (133 lines) | stat: -rw-r--r-- 4,054 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
#
# Copyright (C) 1996-2001, Thomas Andrews
#
# $Id: parscore.tcl 255 2008-09-15 12:43:02Z 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
#

source /usr/share/deal/lib/score.tcl

proc rlist {A B C D} {list $D $C $B $A}

set parscore(order:south) [rlist south west north east]
set parscore(order:west) [rlist west north east south]
set parscore(order:north) [rlist north east south west]
set parscore(order:east) [rlist east south west north]
set parscore(mult:east) -1
set parscore(mult:west) -1
set parscore(mult:north) 1
set parscore(mult:south) 1
set parscore(pair:south) NS
set parscore(pair:north) NS
set parscore(pair:east)  EW
set parscore(pair:west)  EW

proc par_first_upper {word} {
    string toupper [string range $word 0 0]
}

proc par_upcase {word} {
    set first par_first_upper
    set rest [string range $word 1 end]
    append first $rest
}

proc parscore {dealer whovul} {
    deal::metadata parscore.$dealer.$whovul [list parscore_uncached $dealer $whovul]
}

proc parscore_uncached {dealer whovul} {
    if {"$whovul"=="EW"} {
	set vul(EW) vul
        set vul(NS) nonvul
    } elseif {"$whovul"=="NS"} {
        set vul(EW) nonvul
	set vul(NS) vul
    } elseif {"$whovul"=="All"} {
	set vul(EW) vul
	set vul(NS) vul
    } else {
	set vul(EW) nonvul
	set vul(NS) nonvul
    }	

    global parscore

    # Quick call to precompute tricks
    foreach denom {notrump spades hearts diamonds clubs} {
        foreach hand {north east south west} {
	    set tricks($hand:$denom) [deal::tricks $hand $denom]
	}
    }

    set hands $parscore(order:$dealer)

    set bestcontract {Pass}
    set bestdeclarer {}
    set bestscore 0
    set besttricks ""
    set bestauction "Pass   Pass    Pass    Pass"
    set passes(3) "Pass Pass Pass"
    set passes(2) "Pass Pass"
    set passes(1) "Pass"
    set passes(0) ""
    set biggestfit 0

    for {set level 1} {$level<=7} {incr level} {
	set anymake 0
	foreach denom {clubs diamonds hearts spades notrump} {
            set passcount 4
	    foreach declarer $hands {
                if {$denom == "notrump"} {
                  set fit 14
                } else {
                  set fit [expr {[$denom $declarer]+[$denom [partner $declarer]]}]
                }
		incr passcount -1
		set pair $parscore(pair:$declarer)
		if {$tricks($declarer:$denom)<6+$level} { 
		    set makes 0
		    set contract [list $level $denom doubled]
		} else { 
		    set makes 1
		    set anymake 1
		    set contract [list $level $denom]
		}

		set mult $parscore(mult:$declarer)
		set newscore [score $contract $vul($pair) $tricks($declarer:$denom)]
		#puts "Comparing [expr {$mult*$newscore}] in $contract by $declarer to $bestscore in $bestcontract by $bestdeclarer"
		if {$newscore>$mult*$bestscore || (($newscore==$mult*$bestscore) && $fit>$biggestfit) } {
                    set biggestfit $fit
		    set bestcontract $contract
		    set bestdeclarer $declarer
		    set bestscore [expr {$mult*$newscore}]
		    set besttricks $tricks($declarer:$denom)
		    set level [lindex $contract 0]
		    set suit [par_first_upper [lindex $contract 1]]
		    set auction $passes($passcount)
		    lappend auction "$level$suit"
                    if {!$makes} {
			lappend auction "X"
		    }
		    lappend auction 
		    set bestauction $auction
		}
	    }
	}
    }
    list $bestcontract $bestdeclarer $bestscore $besttricks $bestauction
}