Monday, March 28, 2022

Haskell / コーヒーメニューの価格改訂リストの作成改善版

Writer モナドを使ったコーヒーメニューの価格改訂リストの作成の改善版をつくります。新旧のアイテムリストから、同じコーヒー名を持つアイテムを組み合わせたタプルをつくる方法を改善します。 →２つのリストの要素を組み合わせたい（リストモナド）

処理する入力データは次のようにします。(前回と同じです。)

oldItems :: [Item]
oldItems =
  [ Item "Caffe Americano" 400
  , Item "Pike Place Roast" 450
  , Item "Caffe Misto" 500
  ]

nowItems :: [Item]
nowItems =
  [ Item "Caffe Americano" 420
  , Item "Pike Place Roast" 420
  , Item "Cappuccino" 520
  ]

このデータは、以下の３つのエラーがあります。

アイテム Caffe Misto が価格改訂後のリスト(nowItems)に含まれていない
アイテム Cappuccino が価格改訂前のリスト(oldItems)に含まれていない
Pike Place Roast の価格が値下げになっていること（値下げで正しい可能性もあるがここではエラーの可能性ありと考えることにします）

これらを処理中に検査してエラーログを付加して処理を継続するようにコードします。

プロジェクトの準備

$ stack new coffee-price
$ cd coffee-price

package.yml の dependencies に mtl を追加:

dependencies:
- base >= 4.7 && < 5
- mtl

src/Lib.hs

前回とほとんど同じです。ただし、ItemResult に Log を入れるのをやめました。 Item 型の定義を変更して DefaultItem と DummyItem のデータコンストラクタを定義しました。

data Item = DefaultItem Name Price | DummyItem Name deriving Eq

また Item から価格を得るための関数が以前は:

itemPrice :: Item -> Price
itemPrice (Item _ v) = v

でしたが、Item 型の定義が変わったので、以下のようにしました。

maybeItemPrice :: Item -> Maybe Int
maybeItemPrice (DefaultItem _ v) = Just v
maybeItemPrice (DummyItem _) = Nothing

src/Lib.hs コード全体:

module Lib
  ( Name
  , Price
  , Item(DefaultItem, DummyItem)
  , ItemSet
  , ItemResult(ItemResult)
  , itemName
  , maybeItemPrice
  ) where

type Name = String
type Price = Int

data Item = DefaultItem Name Price | DummyItem Name deriving Eq
type ItemSet = (Item, Item)
data ItemResult = ItemResult Name (Maybe Price) (Maybe Price)

itemName :: Item -> String
itemName (DefaultItem v _) = v
itemName (DummyItem v) = v

maybeItemPrice :: Item -> Maybe Price
maybeItemPrice (DefaultItem _ v) = Just v
maybeItemPrice (DummyItem _) = Nothing

instance Show Item where
  show it = foldl1 (\a b -> a ++ "/" ++ b) [(name it), (show $ price it)]
    where
      name = itemName
      price = maybeItemPrice

instance Show ItemResult where
  show it =
    foldl1
      (\a b -> a ++ "/" ++ b)
      [(name it), (show $ oldPrice it), (show $ nowPrice it)]
    where
      name (ItemResult v _ _) = v
      oldPrice (ItemResult _ v _) = v
      nowPrice (ItemResult _ _ v) = v

app/Main.hs

前回からの変更点は、新旧のアイテムリストから ItemSet を作り出すときに、以下の方法を使う点です。

itemSets = do
  oldItem <- oldItems
  nowItem <- nowItems
  guard (itemName oldItem == itemName nowItem)
  return (oldItem, nowItem)

ただし、この処理をする前提条件として、新旧両方のリストに必ず同じコーヒー名のアイテムが１件含まれていてほしいのです。そうでないと、片方のリストにしか存在しないアイテムは itemSets に残らないからです。それは意図したことではない。

ということで、ユニークなコーヒー名リストをつくったら、それがリスト中に含まれているか調べて、含まれていない場合は、DummyItem で埋める処理を追加します。

欠損アイテムを埋めたリストを oldItems', nowItems' としておきます:

-- ユニークなコーヒー名のリスト
itemNames :: [Name]
itemNames = nub $ map (\item -> itemName item) (oldItems ++ nowItems)

-- 欠損しているアイテムを DummyItem で埋める oldItems用
oldItems' = map (\name -> findItemBy name (DummyItem name) ) itemNames
  where
    findItemBy name dummyItem
      | (length $ targetOldItems name)==0 = dummyItem
      | otherwise = head $ targetOldItems name
    targetOldItems name = filter (\item -> (itemName item) == name) oldItems

-- 欠損しているアイテムを DummyItem で埋める nowItems用
nowItems' = map (\name -> findItemBy name (DummyItem name) ) itemNames
  where
    findItemBy name dummyItem
      | (length $ targetNowItems name)==0 = dummyItem
      | otherwise = head $ targetNowItems name
    targetNowItems name = filter (\item -> (itemName item) == name) nowItems

oldItems' の内容:

[ Caffe Americano / Just 400
, Pike Place Roast / Just 450
, Caffe Misto / Just 500
, Cappuccino / Nothing
]

Cappuccino は oldItems に含まれていなかったので DummyItem (価格が Nothing) で埋められています。

nowItems' の内容:

[ Caffe Americano / Just 420
, Pike Place Roast / Just 420
, Caffe Misto / Nothing
, Cappuccino / Just 520
]

Caffe Misto が欠損していたので、 DymmyItem で (価格が Nothing) で埋められています。

それでは、この欠損値を埋めた oldItems', nowItems' を使ってすべての組み合わせを生成し、ガードで同じコーヒー名を持つ組み合わせだけに限定した ItemSet リストを作成します。

itemSets = do
  oldItem <- oldItems'
  nowItem <- nowItems'
  guard (itemName oldItem == itemName nowItem)
  return (oldItem, nowItem)

itemSets の内容:

[ (Caffe Americano / Just 400, Caffe Americano / Just 420)
, (Pike Place Roast / Just 450, Pike Place Roast / Just 420)
, (Caffe Misto / Just 500, Caffe Misto / Nothing)
, (Cappuccino / Nothing, Cappuccino / Just 520)
]

うまくいきました。

あとは ItemSet -> (ItemResult, String) する関数をつくります。

toItemResultWithLog :: ItemSet -> (ItemResult, String)
toItemResultWithLog itemSet = (itemResult, log)
  where
    itemResult = ItemResult (itemName oldItem) maybeOldItemPrice maybeNowItemPrice
    oldItem = fst itemSet
    nowItem = snd itemSet
    maybeOldItemPrice = maybeItemPrice oldItem
    maybeNowItemPrice = maybeItemPrice nowItem
    log 
      | maybeOldItemPrice == Nothing = "old item missing"
      | maybeNowItemPrice == Nothing = "now item missing"
      | isPriceDown == (Just True) = "price down"
      | otherwise = ""

    isPriceDown :: Maybe Bool
    isPriceDown = do
      oldPrice <- maybeOldItemPrice
      nowPrice <- maybeNowItemPrice
      Just (oldPrice > nowPrice)

最後に結果を出します:

results :: [(ItemResult, String)]
results = map (\itemSet -> toItemResultWithLog itemSet) itemSets

results の内容:

[ (Caffe Americano / Just 400 / Just 420, "")
, (Pike Place Roast / Just 450 / Just 420, "price down")
, (Caffe Misto / Just 500 / Nothing, "now item missing")
, (Cappuccino / Nothing / Just 520, "old item missing")
]

ItemResult とログが書き出されています。

完成したコード app/Main.hs

module Main where

import Control.Monad.Writer
import Data.List
import Lib

oldItems :: [Item]
oldItems =
  [ DefaultItem "Caffe Americano" 400
  , DefaultItem "Pike Place Roast" 450
  , DefaultItem "Caffe Misto" 500
  ]

nowItems :: [Item]
nowItems =
  [ DefaultItem "Caffe Americano" 420
  , DefaultItem "Pike Place Roast" 420
  , DefaultItem "Cappuccino" 520
  ]

itemNames :: [Name]
itemNames = nub $ map (\item -> itemName item) (oldItems ++ nowItems)

-- 欠損しているアイテムを DummyItem で埋める oldItems用
oldItems' = map (\name -> findItemBy name (DummyItem name) ) itemNames
  where
    findItemBy name dummyItem
      | (length $ targetOldItems name)==0 = dummyItem
      | otherwise = head $ targetOldItems name
    targetOldItems name = filter (\item -> (itemName item) == name) oldItems

-- 欠損しているアイテムを DummyItem で埋める nowItems用
nowItems' = map (\name -> findItemBy name (DummyItem name) ) itemNames
  where
    findItemBy name dummyItem
      | (length $ targetNowItems name)==0 = dummyItem
      | otherwise = head $ targetNowItems name
    targetNowItems name = filter (\item -> (itemName item) == name) nowItems

itemSets :: [ItemSet]
itemSets = do
  oldItem <- oldItems'
  nowItem <- nowItems'
  guard (itemName oldItem == itemName nowItem)
  return (oldItem, nowItem)

toItemResultWithLog :: ItemSet -> (ItemResult, String)
toItemResultWithLog itemSet = (itemResult, log)
  where
    itemResult = ItemResult (itemName oldItem) maybeOldItemPrice maybeNowItemPrice
    oldItem = fst itemSet
    nowItem = snd itemSet
    maybeOldItemPrice = maybeItemPrice oldItem
    maybeNowItemPrice = maybeItemPrice nowItem
    log 
      | maybeOldItemPrice == Nothing = "old item missing"
      | maybeNowItemPrice == Nothing = "now item missing"
      | isPriceDown == (Just True) = "price down"
      | otherwise = ""

    isPriceDown :: Maybe Bool
    isPriceDown = do
      oldPrice <- maybeOldItemPrice
      nowPrice <- maybeNowItemPrice
      Just (oldPrice > nowPrice)

results :: [(ItemResult, String)]
results = map (\itemSet -> toItemResultWithLog itemSet) itemSets


main :: IO ()
main = print results

Haskell / コーヒーメニューの価格改訂リストの作成 改善版

プロジェクトの準備

src/Lib.hs

app/Main.hs

完成したコード app/Main.hs

Haskell / コーヒーメニューの価格改訂リストの作成改善版