「1から10までの奇数を逆順に表示」で遊ぶ

お題

タイトルのお題をいろいろ妄想して勝手につくったパズル。

【お題】：リスト xs :: [a] と要素に関する述語p :: a -> Bool が与えられた時、xs とは p を満す要素の出現のみ逆順になっているリストを返す関数 revocc :: (a -> Bool) -> [a] -> [a] を定義せよ。ただし、以下の2つの条件を満すものとせよ。

1. $\begin{array}{l} \mathit{revocc}\; \mathit{xs} \in \mathit{permutations}\; \mathit{xs}\end{array}$
2. $\begin{array}{l} \mathit{reverse}\cdot\mathit{map}\;\mathit{fst}\cdot\mathit{filter}\; (p \cdot \mathit{snd})\cdot\mathit{zip}\; [0 ..] \\ \equiv \\ \mathit{map}\; \mathit{fst}\cdot\mathit{filter}\; (p \cdot \mathit{snd}) \cdot \mathit{revocc}\; (p \cdot \mathit{snd}) \cdot \mathit{zip}\; [0 ..] \end{array}$

コード

module RevOcc where

import Data.Bool ( bool )
import Data.List ( mapAccumL )

素朴版

素朴版は、mapAccumLを使って素直に書けます。

素朴版

-- | Simple version
revocc2 :: (a -> Bool) -> [a] -> [a]
revocc2 p xs = snd $ mapAccumL phi (foldl snoc [] xs) xs
    where
        snoc as b = bool as (b : as) (p b)
        phi as b  = bool (as, b) (tail as, head as) (p b)

1パス版

1パス版はrepminのテクニックを使えば書けます。

1パス版

-- | 1 pass version
revocc1 :: (a -> Bool) -> [a] -> [a]
revocc1 p xs = zs
    where
        (ys, zs) = replace [] ys xs
        replace as ys [] = (as, [])
        replace as ys (z:zs)
            | p z       = case replace (z : as) (tail ys) zs of
                (as', zs') -> (as', head ys : zs')
            | otherwise = case replace as ys zs of
                (as', zs') -> (as', z : zs')

1パス版は、パズルとして楽しんでくださいね。読み難いことに見合う性能アップあるわけでもないですから。。。