BF DSL code

ascii85.hs

{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts #-}

import BF
import U32
import Data.Char
import BFUtil
import Control.Monad

u32_printHex ux pzero = do
  let U32 (x0,x1,x2,x3) = ux
  alloc $ \t -> do
  assign t 32
  printHexByte x0 pzero
  putch t
  printHexByte x1 pzero
  putch t
  printHexByte x2 pzero
  putch t
  printHexByte x3 pzero
  putch t

printCR = do
  alloc $ \t -> do
    assign t 10
    putch t

printSPC = do
  alloc $ \sp -> do
    assign sp 32
    putch sp

decoder = do
  allocPair $ \pzero -> do
  alloc $ \notDone -> do
  allocPair $ \x0 -> do
  allocPair $ \x1 -> do
  allocPair $ \x2 -> do
  allocPair $ \x3 -> do
  allocPair $ \x4 -> do
  u32_alloc $ \us -> do
  alloc $ \t -> do
  let U32 (s0,s1,s2,s3) = us

  let readx = do
      forM_ [x4,x3,x2,x1,x0] getch
      assign notDone 1
      allZero [x0,x1,x2,x3,x4] pzero (clear notDone)

  let decode_bytes = do
      forM_ [s0,s1,s2,s3] clear
      -- load x0..x4; x0 is least significant character

      assign t 33
      dotimes' t $ do
        forM_ [x0,x1,x2,x3,x4] decr

      -- add x0
      dotimes' x0 $ incr s0

      -- add 85*x1
      dotimes' x1 $ do
        assign t 85
        dotimes' t $ incrPairs [s0, s1, s2, s3] pzero

      -- add 85*85*x2,  85*85 = 256*28 + 57
      dotimes' x2 $ do
        assign t 28
        dotimes' t $ incrPairs [s1,s2,s3] pzero
        assign t 57
        dotimes' t $ incrPairs [s0,s1,s2,s3] pzero

      -- add 85*85*85*x3,  85^3 = 9, 94, 237
      dotimes' x3 $ do
        assign t 9
        dotimes' t $ incrPairs [s2,s3] pzero
        assign t 94
        dotimes' t $ incrPairs [s1,s2,s3] pzero
        assign t 237
        dotimes' t $ incrPairs [s0,s1,s2,s3] pzero

      -- add 85^4*x4,   85^4 = 3, 28, 132, 177
      dotimes' x4 $ do
        assign t 3
        dotimes' t $ incrPairs [s3] pzero
        assign t 28
        dotimes' t $ incrPairs [s2, s3] pzero
        assign t 132
        dotimes' t $ incrPairs [s1, s2, s3] pzero
        assign t 177
        dotimes' t $ incrPairs [s0, s1, s2, s3] pzero

      -- forM_ [s3,s2,s1,s0] (\x -> printHexByte x pzero >> printSPC)
      -- printCR
      forM_ [s3, s2, s1, s0] putch

  let prog = do
      readx
      while notDone $ do
        decode_bytes
        readx

  prog

base m n
  | n < m    = [n]
  | otherwise = let (q,r) = divMod n m in base m q ++ [r]

encoder = do
  allocPair $ \pzero -> do
  alloc     $ \notDone -> do
  u32_alloc $ \ux -> do
  alloc     $ \ndigits -> do
  alloc     $ \hasDigit -> do
  u32_alloc $ \uq -> do
  allocPair $ \pr -> do

  let frameSize = 30
      advance = movep frameSize
      backup = movep (-frameSize)
      next x = trans frameSize x
      prev x = trans (-frameSize) x

  let read_ux = u32_read ux notDone pzero

  let printNL = do
      alloc $ \t -> do
      assign t 10
      putch t

  -- ux contains number to print
  let printBase85 = do
        let pr' = second pr
        assign ndigits 5
        clear (prev hasDigit)
        while ndigits $ do
          -- debug ndigits "ndigits"
          assign hasDigit 1
          u32_div85 ux uq pr pzero
          u32_copy' uq (next ux)
          copy ndigits (next ndigits)
          advance
          decr ndigits
        backup
        while hasDigit $ do
          copy'' pr' pr
          -- printHexByte pr pzero; printSPC  -- XXX change this
          incr_by pr 33; putch pr
          backup
        advance
  
  let prog = do
        advance
        read_ux
        while notDone $ do
          printBase85
          read_ux

  let test1 = do
        read_ux
        while notDone $ do
          u32_printHex ux pzero
          printNL
          read_ux

  {-
  let test2 = do
        u32_clear ux
        assign (u3 ux) 12
        u32_print ux

  let test3 = do
        u32_clear ux
        assign (u0 ux) 87
        u32_print ux
        u32_div85 ux pr uq pzero
        u32_print ux
        u32_print uq
        at (R (offset1 pr)) prbyte

  let test4 = do
        u32_clear ux
        assign (u3 ux) 87
        u32_print ux
        u32_div85 ux pr uq pzero
        u32_print ux
        u32_print uq
        at (R (offset1 pr)) prbyte
-}

  prog

main = undefined

major-scales.hs

import BF0
import BFUtil
import Data.Char
import Jump

transfer pa = do
  clear pa
  dotimes' (second_cell pa) (incr pa)

program = do
  allocPair $ \ch -> do
  allocPair $ \error -> do
  allocPair $ \semitone -> do
  allocPair $ \key -> do
  allocPair $ \sharp -> do
  allocPair $ \x -> do
  allocPair $ \pr -> do
  allocPair $ \q -> do
  alloc     $ \ch_sharp -> do

  assign ch_sharp (ord '#')

  getch ch

  clear key
  clear sharp

  readKey ch key error

  ifPairZero error $ readSharp ch sharp error

  skipSpaces ch
  ifPairZero error $ readTone ch semitone error

  ifPairZeroElse error
    (do keyToSemi key x
        dotimes' sharp (incr x)
        dotimes' semitone (incr x)
        assign pr 12
        clear (second_cell pr)
        divide x pr q
        transfer pr
        semiToNote pr key sharp
        printNote key sharp ch_sharp)
    (printError)
  alloc $ \ch_nl -> do
    assign ch_nl (ord '\n')
    putch ch_nl

printError = do
  alloc $ \ch_e -> do
  alloc $ \ch_r -> do
  alloc $ \ch_o -> do
  alloc $ \x -> do
  clear ch_e
  clear ch_r
  clear ch_o
  assign x (ord 'A')
  dotimes' x $ do incr ch_e; incr ch_r; incr ch_o
  assign x 4
  -- e is A+4
  -- o is A+14
  -- r is A+17
  dotimes' x $ do
    incr ch_e
    incr ch_o; incr ch_o; incr ch_o; incr ch_o
    incr ch_r; incr ch_r; incr ch_r; incr ch_r
  decr ch_o
  decr ch_o
  incr ch_r
  putch ch_e; putch ch_r; putch ch_r; putch ch_o; putch ch_r

printNote key sharp ch_sharp = do
  incr_by key (ord 'A')
  putch key 
  dotimes' sharp $ putch ch_sharp

-- convert a semitone to a key and sharp
semiToNote pa key sharp =
  jumpTable pa [key,sharp]
    [ [ 0, 0 ]  --  0 A
    , [ 0, 1 ]  --  1 A#
    , [ 1, 0 ]  --  2 B
    , [ 2, 0 ]  --  3 C
    , [ 2, 1 ]  --  4 C#
    , [ 3, 0 ]  --  5 D
    , [ 3, 1 ]  --  6 D#
    , [ 4, 0 ]  --  7 E
    , [ 5, 0 ]  --  8 F
    , [ 5, 1 ]  --  9 F#
    , [ 6, 0 ]  -- 10 G
    , [ 6, 1 ]  -- 11 G#
    ]

-- skip spaces
skipSpaces ch = do
  alloc $ \notDone -> do
  assign notDone 1
  while notDone $ do
    decr_by ch 32
    ifPairZeroElse ch
      (getch ch)
      (do incr_by ch 32; clear notDone)

-- convert a key (0..6) to a semitone
keyToSemi pa key = do
  jumpTable1 pa key [0, 2, 3, 5, 6, 8, 10]

-- set r if ch is not 'A'..'G'
isNotKey ch r = do
    decr_by ch (ord 'A')
    isGE (ord 'G' - ord 'A' + 1) ch r

-- read a key ('A'..'G')
readKey ch key error = do
  -- ch is already populated
  -- skipSpaces ch
  -- expect a letter
  allocPair $ \r -> do
  isNotKey ch r
  ifPairZeroElse r
    (do copy'' ch key; getch ch)
    (do incr_by ch (ord 'A'); incr error)

readSharp ch sharp error = do
  clear sharp
  decr_by ch (ord '#')
  ifPairZeroElse ch
    (do incr sharp; getch ch)
    (do incr_by ch (ord '#'))

readKeySharp ch key sharp error = do
  clear key
  clear sharp
  readKey ch key error
  ifPairZero error $ readSharp ch sharp error

-- sets r if ch is not a lower or uppercase letter
-- ch is decremented by 'A' or 'a' respectively
isNotLetter ch r = do
  decr_by ch (ord 'A')
  isGE (ord 'Z' - ord 'A' + 1) ch r
  ifPairZeroElse r
    pass
    (do decr_by ch (ord 'a' - ord 'A')
        isGE (ord 'z' - ord 'a' + 1) ch r)

-- read two characters and convert it into a semitone
readTone ch semitone error = do
  alloc     $ \pa -> do
  allocPair $ \r -> do
  allocPair $ \pr -> do
  let ifLetter body = do
        isNotLetter ch r
        ifPairZeroElse r body (incr error)
  ifLetter $ do
  copy'' ch pa
  getch ch
  ifLetter $ do
  dotimes' ch (incr pa)
  assign pr 13
  clear (second_cell pr)
  alloc $ \q -> do
    divide pa pr q
  clear pr
  dotimes' (second_cell pr) (incr pr)
  jumpTable pr [semitone,error]
         [ [  0, 1]   -- hash 0
         , [ 11, 0]   -- hash 1
         , [ 11, 1]   -- hash 2
         , [ 11, 1]   -- hash 3
         , [  0, 0]   -- hash 4
         , [  5, 0]   -- hash 5
         , [  7, 0]   -- hash 6
         , [  3, 0]   -- hash 7
         , [  2, 0]   -- hash 8
         , [  2, 1]   -- hash 9
         , [  2, 1]   -- hash 10
         , [  9, 0]   -- hash 11
         , [  9, 1]   -- hash 12
         ]

main = undefined

U32.hs

{-# LANGUAGE FlexibleContexts #-}

module U32 where

import BF
import Control.Monad

data U32 = U32 (Pair,Pair,Pair,Pair)
  deriving (Read, Show)

instance Translatable U32 where
  trans x (U32 (a,b,c,d)) = U32 (trans x a, trans x b, trans x c, trans x d)

instance Register U32 where
  offset (U32 (a,_,_,_)) = offset a

u32_alloc body = do
  allocPair $ \p0 -> do
  allocPair $ \p1 -> do
  allocPair $ \p2 -> do
  allocPair $ \p3 -> do
  let u = U32 (p0,p1,p2,p3)
  body u

second x = R (offset1 x)

-- divide x by pr; pr' must be 0
-- q is incremented by quotient
-- remainder is in pr'

divide' x pr q pzero = do
  let pr' = R (offset1 pr)
  dotimes' pr' $ incr pr
  -- pr' = 0
  while x $ do
    decr x
    incr pr'
    decr pr
    ifPairZeroElse' pr pzero
      (do incr q; dotimes' pr' (incr pr))
      pass

-- destructive copy of a to b
copy'' a b = do
  clear b
  dotimes a (incr b)

-- destructive copy of ux to uy
u32_copy' ux uy = do
  let U32 (x0,x1,x2,x3) = ux
      U32 (y0,y1,y2,y3) = uy
  copy'' x0 y0
  copy'' x1 y1
  copy'' x2 y2
  copy'' x3 y3

-- set result to 1 if px >= c (a constant)
isGE c px result pzero = do
  alloc $ \t -> do
  alloc $ \s -> do
  assign result 1
  assign t c
  while t $ do
    ifPairZeroElse px pzero
      (do clear result; clear t)
      pass
    decr px
    decr t
    incr s
  dotimes' s (incr px)

printNibble px pzero = do
  alloc $ \r -> do
  isGE 10 px r pzero
  incr_by px 48
  dotimes' r $ incr_by px 7
  putch px

printHexByte px pzero = do
  allocPair $ \pq -> do
  allocPair $ \pr -> do
  let pr' = second pr
  assign pr 16
  clear pr'
  clear pq
  divide' px pr pq pzero
  printNibble pq pzero
  copy'' pr' pq
  printNibble pq pzero

-- increment a chain of pairs representing a multi-byte number
-- least significant pair occurs first in the list
incrPairs [] pzero = return ()
incrPairs (p:ps) pzero = do
  incr p
  ifPairZeroElse p pzero
    (incrPairs ps pzero)
    pass

-- decrement a chain of pairs representing a multi-byte number
-- least significant pair occurs first in the list
decrPairs [] pzero = return ()
decrPairs (p:ps) pzero = do
  ifPairZeroElse p pzero
    (do decrPairs ps pzero)
    pass
  decr p

allZero [] pzero thenClause = thenClause
allZero (p:ps) pzero thenClause =
  ifPairZeroElse p pzero (allZero ps pzero thenClause) (return ())

-- read 4 characters; set notDone if any are non-zero
u32_read ux notDone pzero = do
  let U32 (x0,x1,x2,x3) = ux
  getch x3
  getch x2
  getch x1
  getch x0
  assign notDone 1
  allZero [x0,x1,x2,x3] pzero $ clear notDone

three action = do action; action; action

-- divide ux by 85 leaving quotient in uq and remainder in pr'
u32_div85 ux uq pr pzero = do
  let U32 (x0,x1,x2,x3) = ux
      U32 (q0,q1,q2,q3) = uq
  alloc $ \q -> do
  allocPair $ \r0 -> do
  allocPair $ \r1 -> do
  u32_div85' x0 x1 x2 x3 q0 q1 q2 q3 q r0 r1 pr pzero

-- divide the 4-byte number x0..x3 by 85
-- quotient returned in q0..q3, remainder in pr'
u32_div85' x0 x1 x2 x3 q0 q1 q2 q3 q r0 r1 pr pzero = do
  let pr' = second pr
  forM_ [r0, r1, q0, q1, q2, q3] clear
  clear pr'
  assign pr 85

  divide' x3 pr q3 pzero
  dotimes' pr' $ do
    three (incr q2)
    three (incr q1)
    three (incr q0)
    incr r0
    incr pr

  divide' x2 pr q pzero
  dotimes' q $ incrPairs [q2, q3] pzero
  dotimes' pr' $ do
    three $ incrPairs [q1, q2, q3] pzero
    three $ incrPairs [q0, q1, q2, q3] pzero
    incr r0
    incr pr

  divide' x1 pr q pzero
  dotimes' q $ incrPairs [q1, q2, q3] pzero
  dotimes' pr' $ do
    three $ incrPairs [q0, q1, q2, q3] pzero
    incr r0
    incr pr

  divide' x0 pr q pzero
  dotimes' q $ incrPairs [q0, q1, q2, q3] pzero
  dotimes' pr' $ do incrPairs [r0, r1] pzero; incr pr

  divide' r1 pr q pzero
  dotimes' q $ incrPairs [q0, q1, q2, q3] pzero
  dotimes' pr' $ do incr r0; incr pr

  divide' r0 pr q pzero
  dotimes' q $ incrPairs [q0, q1, q2, q3] pzero