a really tiny sloppy Haskell program to try to teach myself to add/multiply hexadecimal numbers without translating to decimal

learn_hexadecimal.hs

#!/usr/bin/env stack
{- stack --install-ghc script
   --resolver lts-11.4
   --package ilist
   --package mtl
   --package random
 -}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE AllowAmbiguousTypes #-}

module Main where

import Data.Char (digitToInt, intToDigit, isHexDigit)

import Control.Monad
import Data.Monoid
import Control.Monad.State.Lazy
import System.Random
import Text.Read (readMaybe)
import Data.List
import Data.List.Index
import Text.Read (readMaybe)
import System.IO.Unsafe (unsafeInterleaveIO)
import System.Exit (exitSuccess)

type PLevel = Int

data Problem a = Add a a
               | Mult a a
               deriving (Eq, Ord)

class Base b where
    base :: b

modReduce :: Integral a => a -> a -> [a]
modReduce x y
  | x == -1 = [-1]
  | x < 0 && x > -y = [-1, -x]
  | x < y && x >= 0 = [x]
  | otherwise = x `mod` y : modReduce (x `div` y) y

digits :: forall n. (Integral n, Base n) => n -> [n]
digits n = modReduce n base

instance Base Hexadecimal where
    base = Hexadecimal 16

instance Base Int where
    base = 10

adjacentsWith :: (a -> a -> b) -> [a] -> [b]
adjacentsWith f [] = []
adjacentsWith f (_:[]) = []
adjacentsWith f (x:y:ys) = f x y : adjacentsWith f (y:ys)

isNoOp :: (Eq a, Num a) => Problem a -> Bool
isNoOp (Add _ 0) = True
isNoOp (Add 0 _) = True
isNoOp (Mult 0 _) = True
isNoOp (Mult _ 0) = True
isNoOp (Mult 1 _) = True
isNoOp (Mult _ 1) = True
isNoOp _ = False

opsHelper :: (Integral a, Base a) => [Problem a] -> [Problem a]
opsHelper initials = allOperations where
  computeCarry x y = Add (x `mod` base) (y `div` base)
  carries = nub . adjacentsWith computeCarry . reverse . map answerTo
  allOperations = nub $ filter (not . isNoOp) $
    initials
    ++ (carries initials)
    ++ (carries . carries $ initials)

zipWithPad :: (a -> b -> c) -> a -> b -> [a] -> [b] -> [c]
zipWithPad f x y xs ys = zipWith f xs' ys' where
  (xs', ys')
    | length xs < length ys = (xs ++ repeat x, ys)
    | otherwise = (xs, ys ++ repeat y)

individualOperations :: (Base a, Eq a, Integral a) => Problem a -> Int
individualOperations (Add x y) = length $ opsHelper initials where
  initials = nub (zipWithPad Add 0 0 (digits x) (digits y))
individualOperations (Mult x y) = multiplyOps where
  multiplies = zipWith (zipWith Mult) (repeat (digits x)) (map repeat (digits y))
  multiplyOps = sum $ map (fromIntegral . length . opsHelper) multiplies

instance (Show a, Base a, Integral a) => Show (Problem a) where
  show p@(Add a b) = "[" ++ show (individualOperations p) ++ "] " ++ show a ++ " + " ++ show b
  show p@(Mult a b) = "[" ++ show (individualOperations p) ++ "] " ++ show a ++ " * " ++ show b

newtype Hexadecimal = Hexadecimal { decimal :: Int }
    deriving (Eq, Ord, Num, Integral, Real, Enum, Bounded)

instance Show Hexadecimal where
  show n = "0x" ++ map (intToDigit . decimal) (reverse (digits n))

instance Read Hexadecimal where
    readsPrec p [] = []
    readsPrec p (d:ds)
      | isHexDigit d =
          let extra = length ds
              digit = digitToInt d
           in (Hexadecimal $ digitToInt d, ds)
              : map (\ (n, rem) ->
                        ( Hexadecimal
                            ( digit * 16 ^ (extra - length rem)
                            + decimal n)
                        , rem ))
                    (readsPrec p ds)
      | otherwise = []

answerTo :: Num a => Problem a -> a
answerTo (Add a b) = a + b
answerTo (Mult a b) = a * b

randomProblem :: (a -> a -> Problem a) -- a problem type
              -> (Int -> a) -- a morphism to a from a random Int
              -> Int -- an upper bound for the random int
              -> IO (Problem a) -- returns a randomized problem
randomProblem mkProblem mkA upperBound = do
    let mkRand = randomRIO (0, upperBound)
    r1 <- mkRand
    r2 <- mkRand
    pure $ mkProblem (mkA r1) (mkA r2)

genProblem :: PLevel -> IO (Problem Hexadecimal)
genProblem level = do
    isAddition <- randomIO
    if isAddition || level <= 1
       then randomProblem Add Hexadecimal (16 ^ (level + 1) - 1)
       else randomProblem Mult Hexadecimal (16 ^ (level - 1) - 1)

genProblems :: IO [Problem Hexadecimal]
genProblems = go actions where
  go [] = error "impossible: infinite list"
  go xs = do
    front <- sequence (take 100 xs)
    end <- unsafeInterleaveIO (go (drop 100 xs))
    pure $ front ++ end
  difficultySeq x y = replicate x (genProblem y)
  actions = concat $ zipWith difficultySeq (map (\x -> x * x) [2..]) [0..]

data GameState a = GameState
  { responses :: [ProblemResponse a]
  , problems :: [Problem a]
  }
type Game t a = StateT (GameState t) IO a
data ProblemResponse a
  = Correct (Problem a)
  | Incorrect (Problem a) a
  deriving (Eq, Ord)

instance (Show a, Base a, Integral a) => Show (ProblemResponse a) where
  show (Correct p) = "correct: " ++ show p ++ " = " ++ show (answerTo p)
  show (Incorrect p n) = "incorrect: " ++ show p ++ " = " ++ show n

onProblems :: ([Problem a] -> [Problem a]) -> GameState a -> GameState a
onProblems f (GameState x y) = GameState x (f y)

onResponses :: ([ProblemResponse a] -> [ProblemResponse a]) -> GameState a -> GameState a
onResponses f (GameState x y) = GameState (f x) y

peekProblem :: Game a (Problem a)
peekProblem = gets (head . problems)

incorrect :: Eq a => Problem a -> ProblemResponse a -> Bool
incorrect p (Incorrect q _) = p == q
incorrect _ _ = False

processResult :: (Base a, Integral a, Eq a) => ProblemResponse a -> Game a ()
processResult (Correct p) = do
  modify (onProblems (drop 1))
  modify (onResponses (Correct p :))
  lift $ putStrLn "correct :)"
processResult (Incorrect p n) = do
  modify (onResponses (Incorrect p n :))
  pos <- gets (length . takeWhile (incorrect p) . responses)
  modify (onProblems (insertAt (pos * 2 * individualOperations p) p))
  lift $ putStrLn "incorrect, try again"

verify :: (Integral n, Base n, Eq n) => Problem n -> n -> ProblemResponse n
verify p n
  | n == answerTo p = Correct p
  | otherwise = Incorrect p n

data Command
  = Answer Hexadecimal
  | Quit
  | Skip Int
  | History Int

getParsedLine :: IO Command
getParsedLine = do
  putStr "=? "
  l <- getLine
  maybe (err >> getParsedLine) pure $ getAlt . mconcat $ Alt <$>
    [ readQuit l
    , Answer <$> readMaybe l
    , readKeywordNum "skip" Skip l
    , readKeywordNum "history" History l
    ]
 where
   err = putStrLn "couldn't read command; try again"
   isWhiteSpace c = c `elem` [' ', '\t']
   readKeywordNum w f l
     | take (length w) l == w =
       let rest = dropWhile isWhiteSpace (drop (length w) l)
        in f <$> readMaybe rest
     | otherwise = Nothing
   readQuit l
     | l == "quit" || l == ":q" || l == "exit" = Just Quit
     | otherwise = Nothing

doOneProblem :: Game Hexadecimal ()
doOneProblem = do
  p <- peekProblem
  lift $ print p
  command <- lift getParsedLine
  case command of
    Answer a -> processResult (verify p a)
    Quit -> lift $ putStrLn "Goodbye :)" >> exitSuccess
    Skip n -> modify (onProblems (drop n))
    History n -> gets (take n . responses) >>= lift . mapM_ print

main :: IO ()
main = do
  problems <- genProblems
  evalStateT (sequence_ (repeat doOneProblem)) (GameState [] problems)