@prog cscore.muf
1 999 d
1 i
(As its sole author, I explicitly place this code in the public domain.
 Anyone may use it in any way for any purpose, though I would appreciate
 credit where it is due.
					- der Mouse, May 1993
)
: card-suit 1 strcut swap pop ;
: card-value-15
	1 strcut pop
	dup "A" strcmp not if pop "1" then
	"TJQK" over instr if pop "10" then
	atoi
;
: card-value-run
	1 strcut pop
	dup "A" strcmp not if pop "1" then
	dup "T" strcmp not if pop "10" then
	dup "J" strcmp not if pop "11" then
	dup "Q" strcmp not if pop "12" then
	dup "K" strcmp not if pop "13" then
	atoi
;
: compute-select-sum (n16 n8 n4 n2 n1 x n -- n16 n8 n4 n2 n1 x n sum)
	0
	over 1 & if 4 pick + then
	over 2 & if 5 pick + then
	over 4 & if 6 pick + then
	over 8 & if 7 pick + then
	over 16 & if 8 pick + then
;
: sort-2 over over > if swap then ;
: sort-3
	over over < if swap then
	rot sort-2
	rot sort-2
;
: sort-5
	sort-3 -5 rotate -5 rotate sort-3 5 rotate sort-3 rot
	5 rotate sort-3 4 rotate sort-3
;
: score-15s
	" " explode pop
	5 rotate card-value-15
	5 rotate card-value-15
	5 rotate card-value-15
	5 rotate card-value-15
	5 rotate card-value-15
	0
	3 begin (should be "0 begin" for completeness - we optimize)
	compute-select-sum 15 = if swap 1 + swap then
	1 + dup 31 <= while repeat
	pop -6 rotate pop pop pop pop pop 2 *
99 "score-15s" pstack
;
: score-pairs
	" " explode pop
	0
	1 begin
	dup 1 + begin
	over 3 + pick
	over 4 + pick
	1 strncmp not if rot 1 + rot rot then
	1 + dup 5 <= while repeat
	pop 1 + dup 4 <= while repeat
	pop -6 rotate pop pop pop pop pop 2 *
99 "score-pairs" pstack
;
: run-maybe-pick (n16 n8 n4 n2 n1 s n o b -- ... s [nb] n o b)
	3 pick over & if over pick 4 rotate 4 rotate 1 + 4 rotate then
;
: check-run (n16 n8 n4 n2 n1 s n -- n16 n8 n4 n2 n1 s 1/0)
	9 16 begin run-maybe-pick 2 / swap 1 - swap dup 0 > while repeat
	pop swap pop
	begin dup 5 > while
		1 - swap 3 pick 1 + = not if
			begin dup 4 > while 1 - swap pop repeat pop 0
			exit
		then
	repeat
	pop pop 1
;
: score-runs
	" " explode pop
	5 rotate card-value-run
	5 rotate card-value-run
	5 rotate card-value-run
	5 rotate card-value-run
	5 rotate card-value-run
	sort-5
	0
	31 check-run if 5 + then
	dup 0 = if
		15 check-run if 4 + then
		23 check-run if 4 + then
		27 check-run if 4 + then
		29 check-run if 4 + then
		30 check-run if 4 + then
	then
	dup 0 = if
		 7 check-run if 3 + then
		11 check-run if 3 + then
		13 check-run if 3 + then
		14 check-run if 3 + then
		19 check-run if 3 + then
		21 check-run if 3 + then
		22 check-run if 3 + then
		25 check-run if 3 + then
		26 check-run if 3 + then
		28 check-run if 3 + then
	then
	-6 rotate pop pop pop pop pop
99 "score-runs" pstack
;
: score-flushes-
	" " explode pop
	card-suit
	swap card-suit strcat
	swap card-suit strcat
	swap card-suit strcat
	swap card-suit strcat
	dup "ccccc" strcmp not if pop 5 exit then
	dup "ddddd" strcmp not if pop 5 exit then
	dup "hhhhh" strcmp not if pop 5 exit then
	dup "sssss" strcmp not if pop 5 exit then
	4 strcut pop
	dup "cccc" strcmp not if pop 4 exit then
	dup "dddd" strcmp not if pop 4 exit then
	dup "hhhh" strcmp not if pop 4 exit then
	dup "ssss" strcmp not if pop 4 exit then
	pop 0
;
: score-flushes
	score-flushes-
99 "score-flushes" pstack
;
: score-jack
	13 strcut "J" swap strcat instr if 1 else 0 then
99 "score-jack" pstack
;
: score (cards -- score)
	dup score-15s
	over score-pairs +
	over score-runs +
	over score-flushes +
	over score-jack +
	swap pop
;
: main
	dup " --> " strcat swap score intostr strcat me @ swap notify
;
.
c
q