dpwright · June 11, 2015 05:53 · dpwright · Jun 11, 2015
diff --git a/lambdaman.hs b/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
	{-# 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