OS/2 Shareware BBS: 18 REXX/18-REXX.zip/freecell.zip/freecell.cmd

OS/2 REXX Batch file | 1996-09-11 | 23KB | 790 lines

/*rexx*/
/*_____________________________________________________________________________
FreeCell
Philip R Brenan, 1996, [e-mail]
_____________________________________________________________________________*/

parse arg gameDepth; if gameDepth = '' then gameDepth = 1

call setUpSystem

/*_____________________________________________________________________________
The game
_____________________________________________________________________________*/

do game = 1 by 1
  call initializeGame(randomGame())

  do forever
    if countEmptyColumn() = game.!columns then game.!msg = 'Success!'
    call save
/*  call possibleMoves */
    if game.!turn = game.!maxTurn then if autoMove() then iterate
    call drawboard 1
    call input
    call update
  end
end

/*_____________________________________________________________________________
Possible moves
_____________________________________________________________________________*/

possibleMoves: procedure expose game.

  do f = 0 to game.!suites
    do j = 1 to game.!columns
      game.!possible.f.c = 0
    end
  end

  do i = 1 to game.!columns
    do while game.!depth.i > 0 & countEmptyFreeCell() > 0
      do j = 1 to game.!columns
        if i <> j then do
          do j = 1 to game.!columns
            game.!possible.f.c = 0
          end
        end
      end
    end
  end

  call undoCmd
  call save
return

/*_____________________________________________________________________________
Update board
_____________________________________________________________________________*/

update: procedure expose game.
  game.!depth = 0
  do j = 1 to game.!columns
    game.!depth = max(game.!depth, game.!depth.j)
  end
return

/*_____________________________________________________________________________
Auto move
_____________________________________________________________________________*/

autoMove: procedure expose game.
  a.1 = min(cardNo(game.!home.2), cardNo(game.!home.3)) + 1
  a.2 = min(cardNo(game.!home.1), cardNo(game.!home.4)) + 1
  a.3 = a.2
  a.4 = a.1

  do f = 1 to game.!suits
    c = game.!freecell.f
    s = suitNo(c)
    if c > 0 & cardNo(c) <= a.s & homeable(c) > 0 then do
      call drawBoard 0
      call homeFreeCmd f
      call sleep
      return 1
    end
  end

  do j = 1 to game.!columns
    d = game.!depth.j
    if d > 0 then do
      c = game.!board.d.j
      s = suitNo(c)
      if c > 0 & cardNo(c) <= a.s & homeable(c) > 0 then do
        call drawBoard 0
        call homeCmd j
        call sleep
        return 1
      end
    end
  end
return 0

/*_____________________________________________________________________________
Get user input
_____________________________________________________________________________*/

input: procedure expose game. gameDepth
  game.!msg = ''
  pull in
  if length(in) = 0 then in = '?'
  s = translate(left(in, 1))
  game.!thisMove = s in

  if abbrev(s, 'X') then exit

  if abbrev(s, '?') then do
    call sysCls
    say 'FreeCell! Version 1996/09/11'
    say 'Freeware: Philip R Brenan, 1996, [e-mail]'
    say
    say 'C   - move column C to free cell'
    say 'CC  - move column C to home'
    say 'CD  - move column C to column D'
    say 'FFC - move free cell F to column C'
    say 'gN  - play Game N'
    say 'hF  - move free cell F to Home'
    say 'l   - show last move'
    say 'o   - OK, resume play after undo, redo'
    say 'r   - redo last move'
    say 's   - reStart current game'
    say 'u   - undo last move'
    say 'x   - eXit'
    say 'z   - start a nested game'
    say
    say 'Commands can be concatenated'
    say
    say 'any key to continue'
    pull .
    return
  end

  if abbrev(s, 'Z') then do
    call fc(game.!gameDepth + 1)
    return
  end

  if abbrev(s, 'S') then do
    call initializeGame(game.!game)
    return
  end

  if abbrev(s, 'O') then do
    game.!maxTurn = game.!turn
    return
  end

  if abbrev(s, 'U') then do
    call undo
    return
  end

  if abbrev(s, 'L') then do
    say game.!lastMove
    pull .
    return
  end

  if abbrev(s, 'R') then do
    if redo() then return
    game.!thisMove = game.!lastMove
    parse value game.!lastMove with s in
  end

  if abbrev(s, 'G') then do
    n = randomGame()
    if length(in) > 1 then if datatype(substr(in, 2)) = 'NUM' then n = abs(left(substr(in, 2), 5))
    call initializeGame(n)
    return
  end

  if abbrev(s, 'H') then do
    if length(in)= 2 & datatype(substr(in, 2)) = 'NUM',
    then call homeFreeCmd substr(in, 2)
    else game.!msg = 'Invalid free cell for hN command - move free cell N to home'
    return
  end

  drop a.; a. = ''; do i = 1 to length(in); a.i = substr(in, i, 1); a.0 = i; end

  if datatype(in) = 'NUM' then do
    if      length(in) = 1              then call freeCmd     a.1
    else if length(in) = 2 & a.1 \= a.2 then call moveCmd     a.1, a.2
    else if length(in) = 2 & a.1  = a.2 then call homeCmd     a.1
    else if length(in) = 3              then call getFreeCmd  a.1, a.3
    else game.!msg = 'Invalid Move command' in
  end
  else game.!msg = 'Invalid command' in
return

/*_____________________________________________________________________________
Move column to column
_____________________________________________________________________________*/

moveCmd: procedure expose game.
  c = arg(1)
  d = arg(2)

  if invalidColumn(c) | invalidColumn(d) | errorEmptyColumn(c) then return

  di = game.!depth.d
  dc = game.!board.di.d
  if di = 0 then target = 'onto column' d; else target = 'onto' cardLongName(dc);

  ci = game.!depth.c
  sc = game.!board.ci.c
  ci = ci + 1

  if di = 0,
  then maxCards = min((countEmptyFreeCell() + 1) * 2 ** countEmptyColumn() - 1, game.!depth.c)
  else maxCards = min((countEmptyFreeCell() + 1) * 2 ** countEmptyColumn() - 0, game.!depth.c)

  do j = 1 to game.!depth.c
    if j > 1 & \onto4(ci, c, ci - 1, c) then leave
    ci = ci - 1
    cc = game.!board.ci.c

    if j > maxCards then do
      game.!msg = 'I can move' maxCards 'but column' c target 'requires' j 'free cells'
      return;
    end
    if (di = 0 & (j = maxCards /*game.!depth.c*/ | \onto4(ci, c, ci - 1, c))) | onto2(cc, dc) then do
      do k = 1 to j
        si = game.!depth.c - k + 1
        sc = game.!board.si.c
        ti = game.!depth.d + j - k + 1
        game.!board.ti.d = sc
        game.!board.si.c = 0
      end
      game.!depth.d  = game.!depth.d + j
      game.!depth.c  = game.!depth.c - j
      if j > 1,
      then call madeMove j 'cards from column' c target
      else call madeMove cardLongName(sc) ||     target
      return
    end
  end
  game.!msg = 'Cannot move' cardLongName(sc) 'onto' cardLongName(dc)
return

/*_____________________________________________________________________________
Move card to free cell
_____________________________________________________________________________*/

freeCmd: procedure expose game.
  j = arg(1)
  if invalidColumn(j) | errorEmptyColumn(j) then return

  do f = 1 to game.!suits
    if game.!freecell.f = 0 then do
      i = game.!depth.j
      game.!freecell.f = game.!board.i.j
      game.!board.i.j  = 0
      game.!depth.j    = game.!depth.j - 1
      call madeMove cardLongName(game.!freecell.f) 'to free cell' f
      return
    end
  end
  game.!msg = 'No more free cells'
return

/*_____________________________________________________________________________
Move card to home
_____________________________________________________________________________*/

homeCmd: procedure expose game.
  j = arg(1)

  if invalidColumn(j) | errorEmptyColumn(j) then return

  i = game.!depth.j
  c = game.!board.i.j
  s = homeable(c)

  if s > 0 then do
    game.!home.s    = c
    game.!board.i.j = 0
    game.!depth.j   = game.!depth.j - 1
    call madeMove cardLongName(c) 'home'
    return
  end
  game.!msg = 'Cannot move' cardLongName(c) 'home yet'
return

/*_____________________________________________________________________________
Can card be moved home yet? Return suit if possible
_____________________________________________________________________________*/

homeable: procedure expose game.
  c = arg(1)
  s = suitNo(c)
  h = game.!home.s

  if (h = 0 & cardNo(c) = 1) | (cardNo(c) = cardNo(h) + 1) then return s
return 0

/*_____________________________________________________________________________
Move free cell to column
_____________________________________________________________________________*/

getFreeCmd: procedure expose game.
  f = arg(1); j = arg(2)

  if invalidFreeCell(f) | errorEmptyFreeCell(f) | invalidColumn(j) then return

  i  = game.!depth.j
  fc = game.!freecell.f
  jc = game.!board.i.j

  if i > 0 then if \onto2(fc, jc) then do
    game.!msg = 'Cannot move' cardLongName(fc) 'from free cell onto' cardLongName(jc)
    return
  end

  i = i + 1
  game.!depth.j    = i
  game.!board.i.j  = game.!freecell.f
  game.!freecell.f = 0
  call madeMove cardLongName(fc) 'onto' cardLongName(jc)
return

/*_____________________________________________________________________________
Move free cell to home
_____________________________________________________________________________*/

homeFreeCmd: procedure expose game.
  f = arg(1)

  if invalidFreeCell(f) | errorEmptyFreeCell(f) then return

  c = game.!freecell.f
  s = suitNo(c)
  h = game.!home.s

  if (h = 0 & cardNo(c) = 1) | (cardNo(c) = cardNo(h) + 1) then do
    game.!home.s     = c
    game.!freecell.f = 0
    call madeMove cardLongName(c) 'home'
  end
  else game.!msg = 'Cannot move' cardLongName(c) 'home yet'
return

/*_____________________________________________________________________________
Made a move
_____________________________________________________________________________*/

madeMove: procedure expose game.
  t = arg(1)
  turn           = game.!turn + 1
  game.!turn     = turn
  game.!maxTurn  = turn
  game.!msg      = 'Moved' t
  game.!lastMove = game.!thisMove
return

/*_____________________________________________________________________________
Count empty free cells, columns
_____________________________________________________________________________*/

countEmptyFreeCell: procedure expose game.
  n = 0
  do f = 1 to game.!suits
    if game.!freecell.f = 0 then n = n + 1
  end
return n

countEmptyColumn: procedure expose game.
  n = 0
  do j = 1 to game.!columns
    if game.!depth.j = 0 then n = n + 1
  end
return n

/*_____________________________________________________________________________
Error if there are no cards in a free cell or a column
_____________________________________________________________________________*/

errorEmptyFreeCell: procedure expose game.
  f = arg(1)
  if game.!freecell.f = 0 then do
    game.!msg = 'No cards in free cell' f
    return 1
  end
return 0

errorEmptyColumn: procedure expose game.
  j = arg(1)
  if game.!depth.j = 0 then do
    game.!msg = 'No cards in column' j
    return 1
  end
return 0

/*_____________________________________________________________________________
Invalid column or free cell?
_____________________________________________________________________________*/

invalidFreeCell: procedure expose game.
  f = arg(1)

  if f < 1 | f > game.!suits then do
    game.!msg = 'Invalid free cell' f 'specified'
    return 1
  end
return 0

invalidColumn: procedure expose game.
  j = arg(1)

  if j < 1 | j > game.!columns then do
    game.!msg = 'Invalid column' j 'specified'
    return 1
  end
return 0

/*_____________________________________________________________________________
Check whether one card can be place on top of another.
2 - Card number
4 - Board Cordinates
_____________________________________________________________________________*/

onto2: procedure expose game.
 sc = arg(1)
 tc = arg(2)

 if cardRed(sc) \= cardRed(tc) & cardNo(sc) = cardNo(tc) - 1 then return 1
return 0

onto4: procedure expose game.
 sr = arg(1); sc = arg(2)
 tr = arg(3); tc = arg(4)

 sc = game.!board.sr.sc
 tc = game.!board.tr.tc

return onto2(sc, tc)

/*_____________________________________________________________________________
Draw the current state of the game
_____________________________________________________________________________*/

drawboard: procedure expose game.
  mode = arg(1)

  parse value SysTextScreenSize() with game.!rows game.!cols
  game.!board = ''; game.!boardColor = ''

  row = 1; cols = game.!columns; colw = game.!cols / game.!suits / 2

  call out center('Free Cell !', game.!cols), row, 1
  call out 'Game' game.!game', turn' game.!turn', max' game.!maxTurn, row, 1
  text = 'Depth ' game.!gameDepth
  call out text, row, game.!cols - length(text)

  row = row + 1
  call out copies(copies('-', colw - 1)'+', game.!suits), row, 1
  call out copies('=', colw * game.!suits), row, game.!cols / 2 + 1

  do i = 1 to game.!suits;
    call out i, row, 1 + (i - 1) * colw + colw / 2 - length(i) / 2 - 1
  end

  do i = 1 to 3
    call out '|', row + i, game.!cols / 2
  end

  row = row + 1
  do i = 1 to game.!suits;
    c = game.!freecell.i
    if c > 0 then do
      parse value cardName(c) with suit card
      if suit \= '' then do
        color = colorCard(c)
        col   = 1 + (i - 1) * colw
        call out center(card, colw), row,     col, color
        call out center('of', colw), row + 1, col, color
        call out center(suit, colw), row + 2, col, color
      end
    end

    c = game.!home.i
    parse value cardName(c) with suit card
    if suit \= '' then do
      color = colorCard(c)
      col   = game.!cols / 2 + 1 + (i - 1) * colw
      call out center(card, colw), row,     col, color
      call out center('of', colw), row + 1, col, color
      call out center(suit, colw), row + 2, col, color
    end
  end

  row = row + 3
  call out copies(copies('-', colw - 1)'+', cols), row, 1

  do i = 1 to game.!columns;
    call out i, row, 1 + (i - 1) * colw + colw / 2 - length(i) / 2 - 1
  end

  do i = 1 to game.!depth
    do j = 1 to cols
      if i <= game.!depth.j then do
        c = game.!board.i.j
        if c > 0 then do
          col = 1 + (j - 1) * colw
          parse value cardName(c) with suit card
          call out card, row + i,     col, colorCard(c)
        end
      end
    end
  end

  row = row + game.!depth + 3
  call out game.!msg, row, 1

  if mode = 0 then text = 'Auto moving ...'
  else             text = 'Enter Command, X to exit, ENTER for help:'
  row = row + 2
  call out text, row, 1

  call InsertColour

  if game.!turn = 1 then call syscls
  call sysCurPos 0, 0
  call charout , left(game.!board, length(game.!board) + game.!cols)
  call sysCurPos row - 1, length(text) + 2
return

/*_____________________________________________________________________________
Insert colors - done in reverse to preserve card positions
_____________________________________________________________________________*/

InsertColour: procedure expose game.
  normalText = D2C(27)'[0m'D2C(27)'[37m'      /* light gray  */
  redCard    = D2C(27)'[1m'D2C(27)'[31m'      /* bright red  */
  blackCard  = D2C(27)'[1m'D2C(27)'[34m'      /* bright blue */

  b = game.!board; c = reverse(game.!boardColor); l = length(b); t = normalText;

  i = verify(c, ' ')
  s = substr(c, i, 1)
  do while i > 0
    j = verify(c, ' ',, i + 1)
    if j > 0 then t = substr(c, j, 1); else t = ''
    if t \= s then do
      select
        when s = 'n' then b = insert(normalText, b, l - i + 1)
        when s = 'b' then b = insert(blackCard,  b, l - i + 1)
        when s = 'r' then b = insert(redCard,    b, l - i + 1)
        otherwise nop
      end
    end
    s = t; i = j
  end
  game.!board = b
return


InsertColour: procedure expose game.
  normalText = D2C(27)'[0m'D2C(27)'[37m'      /* light gray  */
  redCard    = D2C(27)'[1m'D2C(27)'[31m'      /* bright red  */
  blackCard  = D2C(27)'[1m'D2C(27)'[34m'      /* bright blue */

  b = game.!board; c = game.!boardColor; t = normalText;

  do i = 1 to length(b)
    s = substr(c, i, 1)
    if pos(s, 'nbr') > 0 then do
      select
        when s = 'n' then t = t''normalText
        when s = 'b' then t = t''blackCard
        when s = 'r' then t = t''redCard
        otherwise nop
      end
    end
    t = t''substr(b, i, 1)
  end
  game.!board = t
return

/*_____________________________________________________________________________
Write a string into the output buffer
_____________________________________________________________________________*/
out:
/*out: procedure expose game.*/
  t = strip(arg(1), 't')
  c = arg(4); if c = '' then c = 'n'
  p = (arg(2) - 1) * game.!cols + format(arg(3),,0)
  game.!board      = overlay(t,   game.!board,      p)
  game.!boardColor = overlay(c,   game.!boardColor, p)
  game.!boardColor = overlay('n', game.!boardColor, p + length(t))
return

/*_____________________________________________________________________________
Generate a random game
_____________________________________________________________________________*/

randomGame: return random(1, 99999)

/*_____________________________________________________________________________
Initialize a game
_____________________________________________________________________________*/

initializeGame: procedure expose game. gameDepth
  drop game.; game. = 0; game.!msg = 'New Game' arg(1); game.!game = arg(1)
  game.!turn = 1; game.!maxTurn = 1; game.!gameDepth = gameDepth

  call cards; cards = game.!suits * game.!cards
  game.!columns = game.!suits * 2

  do i = 1 to cards; place.i = i; end

  j = random(1, cards, game.!game)
  do i = 1 to cards * cards
    j = random(1, cards)
    k = random(1, cards)
    t = place.j; place.j = place.k; place.k = t
  end

  do i = 1 to game.!suits; game.!freecell.i = 0; game.!home.i = 0; end

  cardNo = 0
  do i = 1 by 1
    do j = 1 to game.!columns
      cardNo = cardNo + 1
      if cardNo <= cards then do
        game.!board.i.j = place.cardNo
        game.!depth.j = i
        game.!depth   = max(i, game.!depth)
      end
      else leave i
    end
  end
return

/*_____________________________________________________________________________
The cards
_____________________________________________________________________________*/

cards: procedure expose game.
  s = 'spades hearts diamonds clubs'

  game.!suits = words(s)
  do i = 1 to words(s)
    game.!suit.i = word(s, i)
  end

  s = '01-ace 02-two 03-three 04-four 05-five 06-six 07-seven 08-eight 09-nine 10-ten 11-jack 12-queen 13-king'

  game.!cards = words(s)
  do i = 1 to words(s)
    game.!card.i = word(s, i)
  end
return

/*_____________________________________________________________________________
Card name from card number
_____________________________________________________________________________*/

cardName: procedure expose game.
  n    = arg(1)
  if n = 0 then return ''
  card = cardNo(n);
  suit = suitNo(n);
  card = game.!card.card
  suit = game.!suit.suit

  select
    when abbrev(suit, 's') then card = translate(overlay(d2c(6), card, 3));
    when abbrev(suit, 'h') then card = overlay(d2c(3), card, 3);
    when abbrev(suit, 'd') then card = overlay(d2c(4), card, 3);
    when abbrev(suit, 'c') then card = translate(overlay(d2c(5), card, 3));
    otherwise
  end
return suit card

/*_____________________________________________________________________________
Card long name from card number
_____________________________________________________________________________*/

cardLongName: procedure expose game.
  parse value cardName(arg(1)) with suit card
return ''''card 'of' suit''''

/*_____________________________________________________________________________
Card color
_____________________________________________________________________________*/

cardRed: procedure expose game.
  n = suitNo(arg(1))
return n = 2 | n = 3

colorCard: procedure expose game.
if cardRed(arg(1)) then return 'r'; else return 'b'

/*_____________________________________________________________________________
Card/Suite number from card number
_____________________________________________________________________________*/

cardNo: procedure expose game. ; return (arg(1) - 1) // game.!cards + 1
suitNo: procedure expose game. ; return (arg(1) - 1) %  game.!cards + 1

/*_____________________________________________________________________________
System set up
_____________________________________________________________________________*/

setUpSystem:
  call RxFuncAdd 'SysLoadFuncs', 'RexxUtil', 'SysLoadFuncs'
  call SysLoadFuncs
return

/*_____________________________________________________________________________
Sleep
_____________________________________________________________________________*/

sleep:
  call sysSleep 1
return

/*_____________________________________________________________________________
Save
_____________________________________________________________________________*/

save: procedure expose game.
  state =           game.!turn game.!maxTurn game.!game game.!columns game.!rows game.!cols game.!depth game.!suits game.!cards
  do i = 1 to game.!suits
    state = state game.!suite.i game.!freecell.i game.!home.i
  end
  do i = 1 to game.!cards
    state = state game.!cards.i
  end
  do i = 1 to game.!columns
    state = state game.!depth.i
    do j = 1 to game.!depth.i
      state = state game.!board.i.j
    end
  end
  state = state game.!msg
  turn = game.!turn
  game.!state.turn = state
return

/*_____________________________________________________________________________
Undo
_____________________________________________________________________________*/

undo: procedure expose game.
  if game.!turn > 1 then do
    turn = game.!turn - 1
    state = game.!state.turn

    parse var state game.!turn .             game.!game game.!columns game.!rows game.!cols game.!depth game.!suits game.!cards state
    do i = 1 to game.!suits
      parse var state game.!suite.i game.!freecell.i game.!home.i state
    end
    do i = 1 to game.!cards
      parse var state game.!cards.i state
    end
    do i = 1 to game.!columns
      parse var state game.!depth.i state
      do j = 1 to game.!depth.i
        parse var state game.!board.i.j state
      end
    end
    parse var state game.!msg
  end
return

/*_____________________________________________________________________________
Redo
_____________________________________________________________________________*/

redo: procedure expose game.
  if game.!turn < game.!maxTurn then do
    game.!turn = game.!turn + 2
    call undo
    return 1
  end
return 0