Hello! Here is a new version of the Warlord chess pieces. Now for the same price you have a custom cursor. :)
Code: Select all
' chessboard.bas
#include "fbgfx.bi"
#include "colors.bi"
#include "pieces.bi"
#include "cursor.bi"
const BRDX = 0
const BRDY = 0
const SQRW = 48
const BRDW = 8 * SQRW
const BUFW = 10 * SQRW
const LSC = colors.MEDIUMSLATEBLUE
const DSC = colors.SLATEBLUE
const A = 1
const H = 8
const EMPTY = 0
const PAWN = 1
const KING = 6
const BLACK = -1
const BACKGROUND = 0
const DARKSQUARE = 7
const GRAB = 1
const GRABBING = 2
const CURW = 32
const SLASHFILL = true
const UPSIDEDOWN = false
PiecePlacement:
data -2,-3,-4,-5,-6,-4,-3,-2
data -1,-1,-1,-1,-1,-1,-1,-1
data 0, 0, 0, 0, 0, 0, 0, 0
data 0, 0, 0, 0, 0, 0, 0, 0
data 0, 0, 0, 0, 0, 0, 0, 0
data 0, 0, 0, 0, 0, 0, 0, 0
data 1, 1, 1, 1, 1, 1, 1, 1
data 2, 3, 4, 5, 6, 4, 3, 2
ScreenRes(BRDW, BRDW, 32,, fb.GFX_NULL)
dim shared as integer board(A to H, 1 to 8)
dim shared as fb.image ptr images(BLACK * KING to DARKSQUARE)
dim shared as fb.image ptr cursor(BACKGROUND to GRABBING)
dim shared as integer mx, my, mb, ox = 0, oy = 0, cur = GRAB
dim buffer as fb.image ptr = ImageCreate(BUFW, BUFW, LSC)
declare sub CreateImages()
declare sub DestroyImages()
declare sub DrawImages()
declare sub LoadBoard()
declare sub Redraw(aBuffer as fb.image ptr)
declare sub BufferToScreen(aBuffer as fb.image ptr)
declare sub RedrawBackgroundImage(aX as const integer, aY as const integer)
declare function XToBoard() as integer
declare function YToBoard() as integer
declare function XYToName(aX as const integer, aY as const integer) as string
declare sub PreventCursorExit()
CreateImages()
DrawImages()
LoadBoard()
ScreenRes(BRDW, BRDW, 32)
WindowTitle("Warlord Chessboard")
SetMouse ,, 0
Redraw(buffer)
BufferToScreen(buffer)
dim as integer dx, dy, brd, px, py
dim key as string
dim forceRedraw as boolean = false
do
Sleep(1)
if GetMouse(mx, my,, mb) = 0 then
PreventCursorExit()
if (cur = GRAB) andalso (mb = 1) andalso (board(XToBoard(), YToBoard()) <> EMPTY) then
cur = GRABBING
dx = SQRW * (mx \ SQRW) - mx
dy = SQRW * (my \ SQRW) - my
px = XToBoard()
py = YToBoard()
brd = board(px, py)
RedrawBackgroundImage(px, py)
forceRedraw = true
elseif (cur = GRABBING) andalso (mb = 0) then
cur = GRAB
board(px, py) = EMPTY
px = XToBoard()
py = YToBoard()
board(px, py) = brd
Redraw(buffer)
BufferToScreen(buffer)
end if
if cbool((mx <> ox) or (my <> oy)) or forceRedraw then
if cbool(cur = GRABBING) and not forceRedraw then
Put buffer, (ox + dx + SQRW, oy + dy + SQRW), images(BACKGROUND), PSET
Get buffer, (mx + dx + SQRW, my + dy + SQRW)-(mx + dx + 2 * SQRW - 1, my + dy + 2 * SQRW - 1), images(BACKGROUND)
Put buffer, (mx + dx + SQRW, my + dy + SQRW), images(brd), TRANS
else
forceRedraw = false
if (ox <> 0) and (oy <> 0) then
Put buffer, (ox + SQRW - 16, oy + SQRW - 16), cursor(BACKGROUND), PSET
end if
end if
Get buffer, (mx + SQRW - 16, my + SQRW - 16)-(mx + SQRW + 15, my + SQRW + 15), cursor(BACKGROUND)
Put buffer, (mx + SQRW - 16, my + SQRW - 16), cursor(cur), TRANS
BufferToScreen(buffer)
ox = mx
oy = my
end if
end if
key = InKey
loop until (key = Chr(255) & "k") or (key = Chr(27))
SetMouse ,, 1
DestroyImages()
sub CreateImages()
for i as integer = BLACK * KING to DARKSQUARE
images(i) = ImageCreate(SQRW, SQRW)
next i
for i as integer = BACKGROUND to GRABBING
cursor(i) = ImageCreate(CURW, CURW)
next i
end sub
sub DestroyImages()
for i as integer = BLACK * KING to DARKSQUARE
ImageDestroy(images(i))
next i
for i as integer = BACKGROUND to GRABBING
ImageDestroy(cursor(i))
next i
end sub
sub DrawImages()
const SYMBOLS = "prnbqk"
dim datum as string
dim as uinteger c1, c2
Restore WarlordChessPieces
for i as integer = PAWN to KING
for y as integer = 0 to SQRW - 1
Read(datum)
for x as integer = 0 to SQRW - 1
select case as const datum[x]
case asc("0")
c1 = colors.MAGENTA
c2 = colors.MAGENTA
case asc("1")
c1 = colors.GRAY
c2 = colors.GRAY
case asc("2")
c1 = colors.IVORY
c2 = colors.BLACK
end select
PSet images( i), (x, y), c1
PSet images(-i), (x, y), c2
next x
next y
next i
if SLASHFILL then
for i as integer = BLACK * KING to KING
if i = BACKGROUND then
continue for
end if
for x as integer = 1 to SQRW - 2
for y as integer = 1 to SQRW - 2
if Point(x, y, images(i)) = colors.MAGENTA then
if (Point(x, y - 1, images(i)) = colors.GRAY) _
or (Point(x + 1, y - 1, images(i)) = colors.GRAY) _
or (Point(x + 1, y, images(i)) = colors.GRAY) _
or (Point(x + 1, y + 1, images(i)) = colors.GRAY) _
or (Point(x, y + 1, images(i)) = colors.GRAY) _
or (Point(x - 1, y + 1, images(i)) = colors.GRAY) _
or (Point(x - 1, y, images(i)) = colors.GRAY) _
or (Point(x - 1, y - 1, images(i)) = colors.GRAY) then
PSet images(i), (x, y), LSC
end if
end if
next y
next x
next i
for x as integer = 0 to SQRW - 1
for y as integer = 0 to SQRW - 1
PSet images(DARKSQUARE), (x, y), iif((x + y) mod 5 = 2, colors.BLACK, colors.MAGENTA)
next y
next x
else
Line images(DARKSQUARE), (0, 0)-(SQRW - 1, SQRW - 1), DSC, BF
end if
Restore HandCursor:
for i as integer = GRAB to GRABBING
for y as integer = 0 to CURW - 1
Read datum
for x as integer = 0 to CURW - 1
select case as const datum[x]
case asc("0")
PSet cursor(i), (x, y), colors.MAGENTA
case asc("1")
PSet cursor(i), (x, y), colors.BLACK
case asc("2")
PSet cursor(i), (x, y), &hFFEFFF
end select
next x
next y
next i
if false then
for i as integer = PAWN to KING
BSave "w" & mid(SYMBOLS, i, 1) & ".bmp", images(i)
BSave "b" & mid(SYMBOLS, i, 1) & ".bmp", images(-i)
next i
BSave "darksquare.bmp", images(DARKSQUARE)
BSave "grab.bmp", cursor(GRAB)
BSave "grabbing.bmp", cursor(GRABBING)
end if
end sub
sub LoadBoard()
Restore PiecePlacement:
for y as integer = 8 to 1 step -1
for x as integer = A to H
Read(board(x, y))
next x
next y
end sub
sub Redraw(aBuffer as fb.image ptr)
dim as integer xToBuf, yToBuf
Line aBuffer, (0, 0)-(BUFW, BUFW), LSC, BF
for y as integer = 1 to 8
for x as integer = A to H
xToBuf = x * SQRW
yToBuf = IIf(UPSIDEDOWN, y, 9 - y) * SQRW
if (x + y) mod 2 = 0 then
Put aBuffer, (xToBuf, yToBuf), images(DARKSQUARE), TRANS
end if
if board(x, y) <> EMPTY then
Put aBuffer, (xToBuf, yToBuf), images(board(x, y)), TRANS
end if
next x
next y
if (mx <> 0) or (my <> 0) then
Get aBuffer, (mx + SQRW - 16, my + SQRW - 16)-(mx + SQRW + 15, my + SQRW + 15), cursor(BACKGROUND)
Put aBuffer, (mx + SQRW - 16, my + SQRW - 16), cursor(cur), TRANS
end if
end sub
sub BufferToScreen(aBuffer as fb.image ptr)
Put (BRDX, BRDY), aBuffer, (SQRW, SQRW)-(9 * SQRW - 1, 9 * SQRW - 1), PSET
end sub
sub RedrawBackgroundImage(aX as const integer, aY as const integer)
if SLASHFILL then
Line images(BACKGROUND), (0, 0)-(SQRW - 1, SQRW - 1), LSC, BF
if (aX + aY) mod 2 = 0 then
Put images(BACKGROUND), (0, 0), images(DARKSQUARE), (0, 0)-(SQRW - 1, SQRW - 1), TRANS
end if
else
Line images(BACKGROUND), (0, 0)-(SQRW - 1, SQRW - 1), iif((aX + aY) mod 2 = 1, LSC, DSC), BF
end if
end sub
function XToBoard() as integer
return mx \ SQRW + 1
end function
function YToBoard() as integer
return IIf(UPSIDEDOWN, my \ SQRW + 1, 8 - my \ SQRW)
end function
function XYToName(aX as const integer, aY as const integer) as string
return Chr(Asc("a") - 1 + aX, Asc("1") - 1 + aY)
end function
sub PreventCursorExit()
const BORDER = 12
if mx < BORDER then
mx = BORDER
elseif mx > BRDW - 1 - BORDER then
mx = BRDW - 1 - BORDER
end if
if my < BORDER then
my = BORDER
elseif my > BRDW - 1 - BORDER then
my = BRDW - 1 - BORDER
end if
end sub