z80 example

lambdaman.hs

{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

import Prelude   hiding (print, and, or)
import Data.Bits hiding (xor, bit)
import Data.Word

import Data.ByteString (ByteString, pack)
import qualified Data.ByteString as BS

import Z80
import ZXSpectrum
import ZXSpectrum.Rom48

main = defaultMain "lambdaman" "lambdaprog" . org 0x6000 $ mdo
  -- Set up colours
  setBorderColour BLACK
  setAttrs AttrDefault False True BLACK WHITE
  call CL_ALL

  -- Load UDGs
  ldVia HL [0x5c7b] udgs -- 0x5c7b specifies the UDG location

  -- Initialise coordinates.
  ldVia HL [plx] $ coords 21 15  -- load hl pair with starting coords.

  withLabel $ \mloop -> do
    -- Delete the player
    call basexy
    call wspace

    -- Now we've deleted the player we can move him before redisplaying him
    -- at his new coordinates.
    ld BC 0xf7fe        -- keyboard row 1-5/joystick port 2.
    in_ A [C]           -- see what keys are pressed.
    rra                 -- outermost bit = key 1.
    push AF             -- remember the value.
    call NC mpl         -- it's being pressed, move left.
    pop AF              -- restore accumulator.
    rra                 -- next bit along (value 2) = key 2.
    push AF             -- remember the value.
    call NC mpr         -- being pressed, so move right.
    pop AF              -- restore accumulator.
    rra                 -- next bit (value 4) = key 3.
    push AF             -- remember the value.
    call NC mpd         -- being pressed, so move down.
    pop AF              -- restore accumulator.
    rra                 -- next bit (value 8) reads key 4.
    call NC mpu         -- it's being pressed, move up.

    -- Now he's moved we can redisplay the player.
    call basexy         -- set the x and y positions of the player.
    call splayr         -- show player.

    halt                -- delay.

    -- Jump back to beginning of main loop.
    jp mloop

  -- Move player left.
  mpl <- labelled $ do
    ld HL ply           -- remember, y is the horizontal coord!
    ld A [HL]           -- what's the current value?
    and A               -- is it zero?
    ret Z               -- yes - we can't go any further left.
    dec [HL]            -- subtract 1 from y coordinate.
    ret

  -- Move player right.
  mpr <- labelled $ do
    ld HL ply           -- remember, y is the horizontal coord!
    ld A [HL]           -- what's the current value?
    cp 31               -- is it at the right edge (31)?
    ret Z               -- yes - we can't go any further left.
    inc [HL]            -- add 1 to y coordinate.
    ret

  -- Move player up.
  mpu <- labelled $ do
    ld HL plx           -- remember, x is the vertical coord!
    ld A [HL]           -- what's the current value?
    cp 4                -- is it at upper limit (4)?
    ret Z               -- yes - we can go no further then.
    dec [HL]            -- subtract 1 from x coordinate.
    ret

  -- Move player down.
  mpd <- labelled $ do
    ld HL plx           -- remember, x is the vertical coord!
    ld A [HL]           -- what's the current value?
    cp 21               -- is it already at the bottom (21)?
    ret Z               -- yes - we can't go down any more.
    inc [HL]            -- add 1 to x coordinate.
    ret

  -- Set up the x and y coordinates for the player's gunbase position,
  -- this routine is called prior to display and deletion of gunbase.
  basexy <- labelled $ do
    print AT
    print [plx]          -- player vertical coord.
    print [ply]          -- player's horizontal position.
    ret

  -- Show player at current print position.
  splayr <- labelled $ do
    setAttrs AttrTemp False True BLACK CYAN
    print 0x90           -- ASCII code for User Defined Graphic 'A'.
    ret

  wspace <- labelled $ do
    setAttrs AttrTemp False True BLACK WHITE
    print $ chr ' '
    ret

  plx <- labelled . db $ pack [0] -- player's x coordinate.
  ply <- labelled . db $ pack [0] -- player's y coordinate.

  udgs <- labelled $ do
    udg [ "        "
        , " ##     "
        , "   #    "
        , "   #    "
        , "   ##   "
        , "  # #   "
        , " #   #  "
        , " #    # " ]

  end


-- Helpers/utilities
-- I will probably want to move some of these out into the zxspectrum package eventually,
-- but just defining them here for convenience as I come across them.
pattern INK        = 0x10 :: Word8
pattern PAPER      = 0x11 :: Word8
pattern AT         = 0x16 :: Word8

-- Colours
pattern BLACK      = 0x0 :: Word8
pattern BLUE       = 0x1 :: Word8
pattern RED        = 0x2 :: Word8
pattern MAGENTA    = 0x3 :: Word8
pattern GREEN      = 0x4 :: Word8
pattern CYAN       = 0x5 :: Word8
pattern YELLOW     = 0x6 :: Word8
pattern WHITE      = 0x7 :: Word8

-- Extra ROM refs

-- skips the initial check that input values are in range
pattern BORDERFAST = 0x229b :: Location

-- Utils

chr :: Char -> Word8
chr = fromIntegral . fromEnum

print :: Load A c => c -> Z80ASM
print c = ld A c >> rst 16

coords :: Word16 -> Word16 -> Word16
coords x y = x+y*256

-- ldVia (load via) lets you load a value that you couldn't usually load directly
-- by using an intermediate register/memory location.
ldVia :: (Load a c, Load b a) => a -> b -> c -> Z80ASM
ldVia x y z = ld x z >> ld y x

udg :: [String] -> Z80ASM
udg = db . pack . map parseLine where
  parseChar ' ' = 0
  parseChar _   = 1
  parseLine l
    | length l /= 8 = error "Each line in a UDG must be 8 characters"
    | otherwise     = foldr (.|.) 0 $ zipWith shiftL (map parseChar l) [7,6..0]

data AttributeType = AttrDefault | AttrTemp
pattern ATTR_DEFAULT = 0x5c8d :: Location
pattern ATTR_TEMP    = 0x5c8f :: Location
setAttrs :: AttributeType
         -> Bool   -- ^ FLASH mode
         -> Bool   -- ^ BRIGHT mode
         -> Word8  -- ^ Paper colour
         -> Word8  -- ^ Ink colour
         -> Z80ASM
setAttrs attr flash bright paper ink = do
  ld A $ flash' .|. bright' .|. paper .<. 3 .|. ink
  ld [addr attr] A
  where flash'  = if flash  then 0x80 else 0
        bright' = if bright then 0x40 else 0
        addr AttrDefault = ATTR_DEFAULT
        addr AttrTemp    = ATTR_TEMP

setBorderColour :: Word8 -> Z80ASM
setBorderColour border = do
  ld A border
  call BORDERFAST

-- Copied from Z80.Operations.  Should probably be exposed/something?
(.<.) :: Bits a => a -> Int -> a
(.<.) = shiftL

Based on the code here: https://chuntey.wordpress.com/2012/12/19/how-to-write-zx-spectrum-games-chapter-2/