\ VP-cards
\ Card, rank, suit, and deck
\ definitions
\ 
\ $Id: VP-cards.txt,v 1.4 2000/10/25 00:17:42 kris_johnson Exp $

\ Copyright 2000
\ Kristopher D. Johnson
\ 
\ See LICENSE-JacksOrBetter for the
\ conditions under which you may
\ use, redistribute, or modify this 
\ code, or create derived works.

docneeds VP-globals
docneeds VP-zstrings

.( VP-cards... )

\ A card is represented as a 16-bit cell
\ whose lower eight bits contain the
\ rank (2-14) and whose upper eight
\ bits contain the suit

: card-pack ( rank suit -- u )
  8 lshift or ;

: card-unpack ( u -- rank suit )
  dup (hex) FF and 
  swap
  8 rshift
;

: card! ( rank suit adr -- )
  >r card-pack r> ! ;

: card@ ( adr -- rank suit )
  @ card-unpack ;

: card>rank ( adr -- rank )
  card@ drop ;

: card>suit ( adr -- suit )
  card@ nip ;

11 constant Jack
12 constant Queen
13 constant King
14 constant Ace

: RankBounds ( -- max+1 min )
  [ MaxRank 1+ ] literal MinRank ;

\ Return rank as a zero-terminated
\ string
: rank>zstring ( rank -- zadr u )
  dup Ace = if
    drop z" A" exit
  then
  dup King = if
    drop z" K" exit
  then
  dup Queen = if
    drop z" Q" exit
  then
  dup Jack = if
    drop z" J" exit
  then
  u>zstring
;

: .rank ( rank -- )
  rank>zstring type
;

1 constant Diamond
2 constant Club
3 constant Heart
4 constant Spade

Diamond constant MinSuit
Spade constant MaxSuit

: SuitBounds ( -- max+1 min )
  [ MaxSuit 1+ ] literal MinSuit ;

  \ On PalmOS, suit characters
  \ are 141, 142, 143, 144
create Diamond-zstring  141 c, 0 c,
create Club-zstring  142 c, 0 c,
create Heart-zstring  143 c, 0 c,
create Spade-zstring  144 c, 0 c,

: suit>zstring ( suit -- zadr u )
  dup Diamond = if
    drop Diamond-zstring 1 exit
  then
  dup Club = if
    drop Club-zstring 1 exit
  then
  dup Heart = if
    drop Heart-zstring 1 exit
  then
  dup Spade = if
    drop Spade-zstring 1 exit
  then
  drop zbl
;

: suit-in-range? ( suit -- f )
  MinSuit MaxSuit 1+ within ;

\ Print suit
: .suit ( Suit -- )
  dup suit-in-range? 0= if . exit then
  \ On PalmOS, suit characters
  \ are 141, 142, 143, 144
  140 + emit bl emit
;

\ Print card at given address
: .card ( adr -- )
  card@ swap .rank .suit ;

\ Return address of nth element
\ of deck of 52 cards
: Deck ( n -- adr )
  cells [ g >deck ] literal + ;

 0 Deck constant 0Deck
#Deck Deck constant LimDeck

: DeckBounds ( -- LimDeck 0Deck )
  LimDeck 0Deck ;

\ Address of index into Deck
g >ideck constant iDeck

\ Initialize contents of Deck and
\ set iDeck to 0
: init-deck ( -- )
  0 iDeck !
  SuitBounds do
    RankBounds do
      i j iDeck @ Deck card!
      iDeck incr
    loop
  loop
  0 iDeck !
;

\ For each position in deck, exchange
\ card with a randomly selected
\ position
: shuffle-deck ( -- )
  init-deck
  init-rand-seed
  DeckBounds do
    rand #Deck mod Deck
    i swap-cells
  cell +loop
;

\ Copy next card from Deck to
\ given location, and increment
\ iDeck
: draw-card! ( adr -- )
  iDeck @ Deck @ swap !
  iDeck incr
;

\ Print contents of deck
: .deck ( -- )
  DeckBounds do
    i .card
  cell +loop
;

