qwerty.hs

#!/usr/bin/env runhaskell
{-# LANGUAGE BangPatterns #-}
{-
A program to estimate the average distance that one finger has to move between two keys while typing a given text on
european keyboard with different layouts. Note: ~ character is considered to be used very rarely and thus replaces newline
on "shifted" layouts.
-}

import Data.Map (fromList, (!?))
import Data.List

coords = [(x - 0.5, -1.0) | x <- [0.0,1.0..11.0]] -- Number line
         ++ [ (x, 0.0) | x <- [0.0,1.0..11.0]] -- Top line
         ++ [ (x + 0.1, 1.0) | x <- [0.0,1.0..12.0] ] -- Middle line
         ++ [ (x + 0.9, 2.0) | x <- [0.0,1.0..9.0] ] -- Bottom line
         ++ [(5.0, 3.0)] -- Spacebar


-- In format (name, (lower, shifted))
layouts =
  [
    ("qwerty",
      (
        "1234567890-=qwertyuiop[]asdfghjkl;'\\\nzxcvbnm,./ "
      , "!@#$%^&*()_+QWERTYUIOP{}ASDFGHJKL:\"|~ZXCVBNM<>?"
      )
    )
  , ("alphabet",
      (
        "1234567890-=abcdefghijklmnopqrstuvwx\nyz[];',./\\ "
      , "!@#$%^&*()_+ABCDEFGHIJKLMNOPQRSTUVWX~YZ{}:\"<>?|"
      )
    )
  , ("dvorak",
      (
        "1234567890[]',.pyfgcrl/=aoeuidhtns-\\\n;qjkxbmwvz "
      , "!@#$%^&*(){}\"<>PYFGCRL?+AOEUIDHTNS_|~:QJKXBMWVZ"
      )
    )
  ]

layoutMap !layout = fromList $ zip (layout) coords

dist (Just (!x1, !y1)) (Just (!x2, !y2)) = sqrt $ (x1 - x2)^2 + (y1 - y2)^2
dist _ _ = 4.46 -- Average distance between two keys

shiftKey = (0.0, 2.0)

shiftDist = dist (Just shiftKey) -- Left shift. I'm too lazy to consider using the right shift

isShifted (_, !shifted) a = a `elem` shifted

unShift (!lower, !shifted) !a = lower !! (fromJust $ elemIndex a shifted)

fromJust :: Maybe a -> a
fromJust !(Just !v) = v
fromJust !Nothing = error "not found"

letterDist :: (String, String) -> Char -> Char -> Float
letterDist !l@(!lower, !shifted) !a !b
  | isShifted l a = letterDist l b (unShift l a) + shiftDist ((layoutMap shifted) !? a)
  | isShifted l b = letterDist l b a
  | otherwise = dist (m !? a) (m !? b) where m = (layoutMap lower)

sumDist :: (String, String) -> String -> Float
sumDist !l !(!x:y:[]) = letterDist l x y
sumDist l !(!x:y:s) = letterDist l x y + sumDist l (y:s)


totalLength :: (String, String) -> String -> Float
totalLength !l "" = 0
totalLength !l !(!x:xs)
  | isShifted l x = 2 + totalLength l xs
  | otherwise = 1 + totalLength l xs

center = (5.0, 1.0)
distCenter = dist (Just center) -- distance to center key

distLetterCenter :: (String, String) -> Char -> Float
distLetterCenter !l@(!lower, !shifted) !a
  | isShifted l a = (dist (Just center) (Just shiftKey)) + (distCenter $ (layoutMap shifted) !? a)
  | otherwise = distCenter ((layoutMap lower) !? a)

sumDistCenter :: (String, String) -> String -> Float
sumDistCenter !l = foldl (\acc x -> acc + distLetterCenter l x) 0.0

main = interact
       (
         \s ->
           "Layout: average distance between keys, average distance to center (lower is better)\n" ++
           unlines
           [name
             ++ ": "
             ++ (show $ (sumDist l s) / (totalLength l s - 1))
             ++ ", "
             ++ (show $ (sumDistCenter l s) / (totalLength l s - 1))
           | (name, l) <- layouts]
       )