p59a.hs

-- project Euler problem 59
import Control.Arrow ((***))
import Data.Bits (xor)
import Data.Char (chr, ord, isPrint, isSpace, toLower)
import Data.List (group, sort, transpose, unfoldr)

-- mapPair (f,g) (x,y) = (f x, g y)
-- groupsOf n = takeWhile (not . null) . unfoldr (Just . splitAt n)
groupsOf n | n>0 = unfoldr $ \x -> if null x then Nothing else Just(splitAt n x)
split n = transpose . groupsOf n
merge = concat . transpose 

lowers = ['a'..'z']
stdAlphaFreq = [8.2, 1.5, 2.8, 4.3,12.7, 2.2, 2.0, 6.1, 7.0, 0.2, 0.8, 4.0, 2.4,
                6.7, 7.5, 1.9, 0.1, 6.0, 6.3, 9.1, 2.8, 1.0, 2.4, 0.2, 2.0, 0.1]
canonicalize = filter (`elem` lowers) . map toLower
makeHistogram = map (pred . length) . group . sort . (lowers++) . canonicalize
mergeHistogram = foldr1 (zipWith (+))
nonBlankLength = length . filter (not . isSpace) 
percentize n d = (fromIntegral n / fromIntegral d) * 100
chisqr es os = sum $ zipWith (\e o -> ((o-e)^2)/e) es os 
gapToStd total histo = chisqr stdAlphaFreq $ map (flip percentize total) histo
calcAttr plain = (nonBlankLength plain, makeHistogram plain)
calcGap = uncurry gapToStd . (***) sum mergeHistogram . unzip

deCipher keyCh = map $ chr . (ord keyCh `xor`)
listTriples xs = [(calcAttr p,c,p)|c<-lowers,let p=deCipher c xs, all isPrint p]
mixTriples = (\(attrs,cs,ps) -> ((calcGap attrs, cs), merge ps)) . unzip3
p59 = minimum . map mixTriples . sequence . map listTriples . split 3
readCipher = fmap (read . (\s->"["++s++"]")) . readFile
main = print . sum . map ord . snd . p59 =<< readCipher "cipher1.txt"

p59b.hs

-- project Euler problem 59 (using simpler heuristics, although not always safe)
import Data.Bits (xor)
import Data.Char (chr, ord, isPrint, isSpace)
import Data.List (transpose, unfoldr)

groupsOf n | n>0 = unfoldr $ \x -> if null x then Nothing else Just(splitAt n x)
split n  = transpose . groupsOf n
merge    = concat . transpose 

calcAttr = length . filter isSpace
calcGap  = recip . fromIntegral . succ . sum

lowers = ['a'..'z']
deCipher keyCh = map $ chr . (ord keyCh `xor`)
listTriples xs = [(calcAttr p,c,p)|c<-lowers,let p=deCipher c xs, all isPrint p]
mixTriples = (\(attrs,cs,ps) -> ((calcGap attrs, cs), merge ps)) . unzip3
p59 = minimum . map mixTriples . sequence . map listTriples . split 3
readCipher = fmap (read . (\s->"["++s++"]")) . readFile
main = print . sum . map ord . snd . p59 =<< readCipher "cipher1.txt"

p59c.hs

-- project Euler problem 59 (using simpler heuristics, although not always safe)
import Data.Bits (xor)
import Data.Char (chr, ord, isPrint, isSpace)
import Data.List (transpose, unfoldr)
 
partial p x = if p x then Just x else Nothing -- from Control.Monad.Plus
groupsOf n  = unfoldr (partial (not . null . fst) . splitAt n)
split n     = transpose . groupsOf n
merge       = concat . transpose 

calcAttr    = length . filter isSpace
calcGap     = recip . fromIntegral . succ . sum

decode ch   = map $ chr . (ord ch `xor`)
list3 xs    = [(calcAttr p,c,p)|c<-['a'..'z'],let p=decode c xs, all isPrint p]
mix3        = (\(attrs,cs,ps) -> ((calcGap attrs, cs), merge ps)) . unzip3
p59         = minimum . map mix3 . sequence . map list3 . split 3
readCipher  = fmap (read . (\s->"["++s++"]")) . readFile
main        = print . sum . map ord . snd . p59 =<< readCipher "cipher1.txt"

p59d.hs

import Data.Bits (xor)
import Data.Char (chr, ord, isPrint, isSpace)
import Data.List (transpose, unfoldr)
import Control.Arrow ((***))

partial p x = if p x then Just x else Nothing -- from Control.Monad.Plus
groupsOf n  = unfoldr (partial (not . null . fst) . splitAt n)
split n     = transpose . groupsOf n
merge       = concat . transpose 

decode ch   = map $ chr . (ord ch `xor`)
choose xs   = [(n, p)| c <- ['a'..'z'], let p = decode c xs, all isPrint p, let n = spaceNum p, n /= 0] 
  where spaceNum = length . filter isSpace -- perhaps ", n /= 0" might be over-optimization
decrypt     = snd . maximum . map ((sum *** merge) . unzip) . sequence . map choose . split 3
readCipher  = fmap (read . (\s->"["++s++"]")) . readFile
main        = print . sum . map ord . decrypt =<< readCipher "cipher1.txt"

p59d2.hs

import Data.Bits (xor)
import Data.Char (chr, ord, isPrint, isSpace)
import Data.List (transpose, unfoldr)
import Control.Arrow ((***))

partial p x = if p x then Just x else Nothing -- from Control.Monad.Plus
groupsOf n  = unfoldr (partial (not . null . fst) . splitAt n)
split n     = transpose . groupsOf n
merge       = concat . transpose

decode ks   = zipWith dec (cycle ks) where dec k x = chr (ord k `xor` x)
choose xs   = [(centainty p, p)| c <- ['a'..'z'], let p = decode [c] xs, isValid p]
certainty   = length . filter isSpace
isValid     = all (\ch -> isPrint ch || isSpace ch)
deCipher    = snd . maximum . map ((sum *** merge) . unzip) . sequence . map choose . split 3
readCipher  = fmap (read . (\s->"[" ++ s ++ "]")) . readFile
main        = print . sum . map ord . deCipher =<< readCipher "cipher1.txt"

p59d2.type-decl.txt

-- type decls used in p59d2.hs p59e.hs (including library such as Prelude)

main       :: IO ()

print      :: Show a => a -> IO ()
(.)        :: (b -> c) -> (a -> b) -> a -> c
(=<<)      :: Monad m => (a -> m b) -> m a -> m b
(>>=)      :: Monad m => m a -> (a -> m b) -> m b

type Cipher    = [Int]
type Plain     = String
type KeyString = [Char]       -- [Char] is same with String

fmap       :: Functor f => (a -> b) -> f a -> f b
read       :: Read a => String -> a
readFile   :: FilePath -> IO String
readCipher :: FilePath -> IO Cipher

encode     :: KeyString -> Plain  -> Cipher
decode     :: KeyString -> Cipher -> Plain
zipWith    :: (a -> b -> c) -> [a] -> [b] -> [c]
cycle      :: [a] -> [a]

deCipher   :: Cipher -> Plain
sequence   :: Monad m => [m a] -> m [a]
unzip      :: [(a, b)] -> ([a], [b])
maximum    :: Ord a => [a] -> a
sum        :: Num a => [a] -> a
snd        :: (a, b) -> b

choose     :: Cipher -> [(Int, Plain)]
certainty  :: Plain -> Int
isValid    :: Plain -> Bool

merge      :: [[a]] -> [a]
split      :: Int -> [a] -> [[a]]
groupsOf   :: Int -> [a] -> [[a]]
transpose  :: [[a]] -> [[a]]
concat     :: [[a]] -> [a]

unfoldr    :: (b -> Maybe (a, b)) -> b -> [a]
partial    :: (a -> Bool) -> a -> Maybe a
splitAt    :: Int -> [a] -> ([a], [a])
not        :: Bool -> Bool
null       :: [a] -> Bool     -- test whether a list is empty
fst        :: (a, b) -> a

p59e.hs

-- refactored in top-down fashion, some comments and type annotations are added

import Data.Bits (xor)
import Data.Char (chr, ord, isPrint, isSpace)
import Data.List (transpose, unfoldr)
import Control.Arrow ((***))

----------------------------------------------------------------------------
-- Main
--

main :: IO ()
main = print . sum . map ord . deCipher =<< readCipher "cipher1.txt"

type Cipher = [Int]
type Plain  = String
type KeyString = [Char]       -- [Char] is same with String

readCipher :: FilePath -> IO Cipher
readCipher = fmap (read . (\s -> "[" ++ s ++ "]")) . readFile

deCipher :: Cipher -> Plain     -- note: sequence computes cartesian product
deCipher = snd . maximum . map sumUp . sequence . map choose . split 3
  where sumUp :: [(Int, String)] -> (Int, String)
        sumUp = (sum *** merge) . unzip

----------------------------------------------------------------------------
-- choose candidate plains
--

choose :: Cipher -> [(Int, Plain)]
choose xs = [(certainty p, p)| c<-['a'..'z'], let p = decode [c] xs, isValid p]

certainty :: Plain -> Int       -- we use space count as certainty factor
certainty = length . filter isSpace

isValid :: Plain -> Bool
isValid = all (\ch -> isPrint ch || isSpace ch)

----------------------------------------------------------------------------
-- encode/decode a stream using a key string (note: encode is only for debug)
--

encode :: KeyString -> Plain -> Cipher
encode ks = zipWith enc (cycle ks) where enc k c = ord k `xor` ord c

decode :: KeyString -> Cipher -> Plain
decode ks = zipWith dec (cycle ks) where dec k x = chr (ord k `xor` x)

----------------------------------------------------------------------------
-- split a cipher stream / merge decoded plain streams into one
--

split :: Int -> [a] -> [[a]]
split n = transpose . groupsOf n

merge :: [[a]] -> [a]
merge = concat . transpose 

groupsOf :: Int -> [a] -> [[a]]
groupsOf n = unfoldr (partial (not . null . fst) . splitAt n)

partial :: (a -> Bool) -> a -> Maybe a  -- from Control.Monad.Plus
partial p x = if p x then Just x else Nothing

----------------------------------------------------------------------------
-- some test data
--

quote1 = "Here is the key line from Wadler's paper on Monads: (Pure functional languages have this advantage: all flow of data is made explicit. And this disadvantage: sometimes it is painfully explicit.)  That is the problem monads solve: they let you leave implicit some of the repetitive code otherwise required by functional programming. That simple but critical point left out of many monad tutorials. -- John D. Cook"

util.hs

-- utilities for validation
mapOver fns  = zipWith ($) (cycle fns)
encrypt keys = mapOver (map enc keys) where enc k = (ord k `xor`) . ord
decrypt keys = mapOver (map dec keys) where dec k = chr . (ord k `xor`)

util2.hs

partial p x = if p x then Just x else Nothing -- from Control.Monad.Plus

groupsOf' 0 = \_ -> [] -- if you prefer it
groupsOf' n = unfoldr (partial p . splitAt n) where p (h,_) = n==length h

groupsOf  n = unfoldr (partial p . splitAt n) where p (h,_) = (not . null) h

z-p59.lisp

;;;===================================================================
;;; Project Euler
;;; Problem 59 (a porting of gist.github.com/nfunato/9559350#file-p59c-hs)

(defun main (&optional source)
  (sum
   (map 'list #'char-code (decipher (read-source source)))))

(defvar *cipher* nil)

(defun read-source (source)         ; SOURCE can be path, nil, or t.
  (if (eq source t)
      *cipher*
      (setf *cipher* (read-cipher (or source #p"cipher1.txt")))))

(defun read-cipher (path)
  "Read integers separated by comma as a list."
  (read-from-string
   (concat (list "(" (substitute #\space #\, (read-file path)) ")"))))

(defun decipher (integers)
  (flet ((sum-up-score/keychar/phrase-chars (triple)
           (destructuring-bind ((s0 k0 cs0) (s1 k1 cs1) (s2 k2 cs2)) triple
             (list (+ s0 s1 s2)
                   (coerce (list k0 k1 k2) 'string)
                   (list cs0 cs1 cs2)))))
    (destructuring-bind (score keystr chars-list)
        (maximize (mapcar #'sum-up-score/keychar/phrase-chars
                          (cartesian-product
                           (mapcar #'choose-triples (xsplit 3 integers))))
                  :key #'car)
      (declare (ignore score))
      (values (xmerge chars-list) keystr))))

(defun choose-triples (integers)
  (loop for ch across "abcdefghijklmnopqrstuvwxyz"
        for phrase-chars = (decode (list ch) integers)
        when (every #'printable-char-p phrase-chars)
        collect (list (score phrase-chars) ch phrase-chars)))

(defun score (chars)
  (length (filter #'blank-char-p chars)))

; (defun score2 (chars) (loop for c in chars when (blank-char-p c) count it))

(defun enc    (k c)         (logxor (char-code k) (char-code c)))
(defun dec    (k i)         (code-char (logxor (char-code k) i)))
(defun encode (ks chars)    (mapcar #'enc (cycle-list ks) chars))
(defun decode (ks integers) (mapcar #'dec (cycle-list ks) integers))

;;;-------------------------------------------------------------------
;;; general utilities

(defun cycle-list (seq)
  (let ((x (map 'list #'identity seq)))
    (setf (cdr (last x)) x)))

(defun blank-char-p (ch)
  (member ch '(#\space #\return #\linefeed #\newline) :test #'char=))

(defun printable-char-p (ch)
  (or (standard-char-p ch) (blank-char-p ch)))

(defun concat (sequences &optional (type 'string))
  (apply #'concatenate type sequences))

(defun read-file (path)
  (check-type path PATHNAME)
  (with-open-file (st path :direction :input)
    (concat (loop for l = (read-line st nil) while l collect l))))

(defun remove-keyargs (key keyarg-pairs)
  (loop for (p v) on keyarg-pairs by #'cddr unless (eq p key) nconc (list p v)))

(defun maximize (seq &rest rest
                     &key (key #'identity) from-end start end initial-value)
  (declare (ignorable from-end start end initial-value))
  (flet ((fn (a b) (if (> (funcall key a) (funcall key b)) a b)))
    (apply #'reduce #'fn seq (remove-keyargs :key rest))))

(defun cartesian-product (xss)
  (if (null xss)
      '(())
      (destructuring-bind (ys . zss) xss
        (mapcan (lambda (zs) (mapcar (lambda (y) (cons y zs)) ys))
                (cartesian-product zss)))))

(defun sum (xs)
  (reduce #'+ xs :initial-value 0))

(defun filter (fn seq &rest rest)
  (apply #'remove-if-not fn seq rest))

(defun take (n xs)
  (loop for i from 0 below n for x in xs collect x))

(defun groups-of (n xs)
  (cond ((zerop n) (error "groups-of"))
        ((null xs) '())
        (t         (cons (take n xs) (groups-of n (nthcdr n xs))))))

(defun xsplit (n xs)
  (xtranspose (groups-of n xs)))

(defun xmerge (xss &optional (type 'string))
  (concat (xtranspose xss) type))

;; eXtended transpose -- using XMAPCAR/LISTIFY-... instead of MAPCAR/LIST
(defun xtranspose (xss)
  (apply #'XMAPCAR #'LISTIFY-W/O-ENDMARK xss))

;; eXtended mapcar -- using EVERY/CAR+/XMAPCAR instead of SOME/CAR/MAPCAR
(defun xmapcar (fn &rest xss)
  (if (EVERY #'null xss)
      '()
      (cons (apply fn (mapcar #'CAR+ xss))
            (apply #'XMAPCAR fn (mapcar #'cdr xss)))))

(defvar *end-mark* (cons nil nil))  ; any UNIQUE lisp object in terms of EQ

(defun car+ (x)
  (if (endp x) *end-mark* (car x)))

(defun listify-w/o-endmark (&rest xs)
  (remove *end-mark* xs :test #'eq))

#|
(defun transpose (xss)
  (apply #'MAPCAR #'LIST xss))

(defun mapcar (fn &rest xss)
  (if (SOME #'null xss)
      '()
      (cons (apply fn (mapcar #'CAR xss))
            (apply #'MAPCAR fn (mapcar #'cdr xss)))))
|#

z-p59b.lisp

;;;===================================================================
;;; Project Euler Problem 59

(defun main (&optional path)
  (reduce #'+ (decipher (read-cipher path) 'list) :key #'char-code))

(defvar *cipher* nil)           ; cache for debug etc

(defun read-cipher (&optional path)
  "Read integers separated by comma as a list."
  (flet ((patch (s) (substitute #\space #\, (concatenate 'string "(" s ")"))))
    (setq *cipher* (read-from-string (patch (read-file (or path #p"cipher1.txt")))))))

(defun decipher (integers &optional (type 'string))
  (let ((ks (guess-keychars integers)))
    (values (coerce (decode ks integers) type)
            ks)))

(defun guess-keychars (integers)
  (mapcar (lcurry #'guess-keychar integers) '(0 1 2)))

(defun guess-keychar (integers offset)
  (argmax (lcurry2 #'score integers offset) "abcdefghijklmnopqrstuvwxyz"))

(defun score (integers offset keychar)
  (flet ((space-char-p (ch)
           (unless (printable-char-p ch) (return-from score -1))
           (char= ch #\space)))
    (loop for i in (nthcdr offset integers) by #'cdddr
          when (space-char-p (dec keychar i)) count it)))

(defun enc    (k c)         (logxor (char-code k) (char-code c)))
(defun dec    (k i)         (code-char (logxor (char-code k) i)))
(defun encode (ks chars)    (mapcar #'enc (cycle-list ks) chars))
(defun decode (ks integers) (mapcar #'dec (cycle-list ks) integers))

;;; general utilities

(defun lcurry  (f a)   (lambda (b) (funcall f a b)))
(defun lcurry2 (f a b) (lambda (c) (funcall f a b c)))

(defun cycle-list (seq)
  (let ((x (map 'list #'identity seq)))
    (setf (cdr (last x)) x)))

(defun blank-char-p (ch)
  (member ch '(#\space #\return #\linefeed #\newline) :test #'char=))

(defun printable-char-p (ch)
  (or (standard-char-p ch) (blank-char-p ch)))

(defun concat (sequences &optional (type 'string))
  (apply #'concatenate type sequences))

(defun read-file (path)
  (check-type path PATHNAME)
  (with-open-file (st path :direction :input)
    (concat (loop for l = (read-line st nil) while l collect l))))

(defun argbest (cmp seq &rest rest &key key from-end start end)
  (declare (ignorable start end))
  (check-type cmp FUNCTION)
  (check-type key FUNCTION)
  (let* ((null (cons nil nil)) (best-arg null) arg)
    (labels ((fn (x y)
               (if from-end (keep-better x y) (keep-better y x)))
             (keep-better (new old)
               (if (funcall cmp new old) (progn (setq best-arg arg) new) old))
             (key+ (x)
               (when (eq best-arg null) (setq best-arg x))
               (funcall key (setq arg x))))
      (let ((best-val (apply #'reduce #'fn seq :key #'key+ rest)))
        (values best-arg best-val)))))

(defun argmax (fn seq &rest rest &key from-end start end)
  (declare (ignorable from-end start end))
  (apply #'argbest #'> seq :key fn rest))