{-
Copyright  (C)  2020  by  TADASHI TAKEHANA

　配布、配信、公然で口述、販売、改変、をしないでください。

＜コマンドプロンプト用プログラム＞
日記文検索プログラム(指定フォルダー内の全.txt/.TXTファイル対象)

TTnKensaku4.hs
Version 1.01.

著作日時:　2020.02.01.sat.　20:47:00

著、竹花　忠

※注．
先頭に--が付いている行は、コメント行です。プログラムのコードではありません。
また、{-　と　-}　で、挟まれた・囲まれた・括られた、範囲もコメントです。プログラムのコードではありません。

※プログラミング上の注意:
　Haskell言語のソースプログラムのファイルタイプ名は、.hsにしてください。
　なお、Haskell言語のソースプログラムは、UTF8のコード体系で保存してください。


準備作業:
　Haskell言語の開発環境のインストールについては、Haskell Platformをダウンロードします。
http://hackage.haskell.org/platform/から、使用しているOSにあったものをダウンロードしてください。
　ダウンロードしたらインストールしましょう。
　これによって、ghcコマンドが使用できるようになります。

　コマンドプロンプトで、ghc プログラム名と入力してリターンキーを押せば、コンパイルが行われます。
　つまり、コマンドプロンプトで、ghc TTnKensaku4と入力してリターンキーを押せば、コンパイルが行われます。

※注．
　本プログラムの結果ファイル名は、検索対象フォルダー内に、Tfzkbp1sfSELECT*.TXTとTfzkbp1sfRVS*.TXTという名前で作成されます。
　なお、*部分には、数字およびハイフンおよびピリオドが、毎回差し替わって、新たなファイル名を構成します。
　したがって、本プログラムを実行する都度、新たな結果ファイルTfzkbp1sfSELECT*.TXTとTfzkbp1sfRVS*.TXTが、増設されてゆきます。
　不要になった結果ファイルは、必要に応じてご自身で削除するなどしてください。


※注．
　本プログラムが正常に動作するためには、検索対象フォルダー内の、.TXTか.txtか.JKNか.jknのファイルが、ShiftJISのコード体系で保存されている必要があります。
　UTF8など、ほかのコード体系の、.TXTか.txtか.JKNか.jknのファイルが存在していると、本プログラムは、異常終了してしまいます。



　抽出文章の3行手前には、検索対象ファイル中の行番号と、検索対象ファイルの名前を表示します。
　検索対象ファイル中の検出した文章の行番号は、抽出文章の先頭行番号 -- 抽出文章の末尾行番号、という形式で表示します。
　検索対象ファイル名の表示は、in ＜検索対象ファイル名＞、という形式で表示します。
　以上の2項目を1行で表示します。
　行頭から始まる4桁の数字、ピリオド、そして、2桁の数字、ピリオド、また2桁の数字、ピリオド、で始まっている行を、日付とみなす。
　そして抽出文章に、直近のこの日付と思われる文字列を含む行を、@の次に配置して、抽出文章の2行手前に置く。
　さらに、抽出文章の直前には、検索対象ファイル内における抽出件数番号を置く。
　本プログラムは、以上の3行を、各抽出文章ごとに付記します。



使用方法：
　コマンドプロンプトを起動して、実行します。
　コマンドプロンプトに、chcp 932を入力して、コードページをShiftJISに設定します。
　使用するファイルのコード体系は、ShiftJISでなければ、このプログラムは正常に動作しません。
　検索対象ファイルや検索条件ファイルは、ShiftJIS・ANSI、のコード体系で保存してください。
　コマンドプロンプトから、TTnKensaku4 セパレータカウント　検索条件ファイル名　セパレータ　検索対象フォルダー名、を入力してください。
　検索条件ファイル名の指定において、パスを省略した場合には、コマンドプロンプトのカレントフォルダーが使用されます。
　セパレートカウントは、検索対象ファイルの中の文章と文章を、改行文字連続何個で区切るか。
その改行文字の連続個数、を指定する数字です。
　検索条件ファイル名は、全文検索の複合条件を登録したファイル名です。
　ファイルタイプは、.JKNか.jknにする必要があります。
ABCかDEFGかHIを含んでいて、なおかつ、JKLかMNOを含んでいて、なおかつ、PQRかSTUかVWXかYZを含んでいる文章を検索したいなら、
検索条件ファイルに、
ABC
DEFG
HI
++++
JKL
MNO
++++
PQR
STU
VWX
YZ
と登録してください。
　ここで、++++は、検索条件ファイル内のセパレータです。
　セパレータには、特殊文字を使用することはできません。
　セパレータは、検索条件ファイル内のセパレータです。
検索条件ファイルの登録の際に使用したセパレータをタイプしてください。
したがって、上記の例では、++++をセパレータとしてタイプしてください。
　検索対象フォルダー名は、複合条件で全文検索を実施する対象フォルダーの名前です。
　検索対象フォルダー内の.TXTか.txtのファイルだけを対象にして、先に登録した検索条件ファイル内の複合条件にて、全文検索を実施します。
　ただし、検索対象フォルダー名ではなく、テキストファイル名を指定した場合には、指定したテキストファイルに対して複合条件全文検索を実施します。

　繰り返しますが、本プログラムは、指定した1つのフォルダー内の、.TXT　か .txt　のファイルだけを検索対象ファイルにして、複合条件で全文検索を実施するプログラムです。

-}
--　以下よりHaskell言語によるプログラムです。

{-# LANGUAGE OverloadedStrings #-}
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import System.FilePath
import Data.List
import Data.Char
import System.IO
import System.Directory
import System.Environment
import Control.Exception
import Control.Monad
import Data.Time

main = do
   args <- getArgs
   let
      [sepc, joukennam, separator, fdir] = args
      argcnt = length args
   if argcnt /= 4
      then
         putStrLn "使い方 : \nTTnKensaku4 文章末の改行数 検索条件ファイル そのセパレータ 検索対象フォルダ"
      else
         do
            let
               rjoukennam = reverse joukennam
            if (not (isPrefixOf "NKJ." rjoukennam)) && (not (isPrefixOf "nkj." rjoukennam))
               then putStrLn "第2引数のファイルタイプは、.JKNか.jknにします!!"
               else do
                  sonzai <- doesFileExist joukennam
                  if not sonzai
                     then putStrLn $ joukennam ++ "は存在しません!!"
                     else do
                        joukens <- TIO.readFile joukennam

                        let
                           jknseplist = set_kensakuJouken joukens (T.pack separator)

                        case hantei_target fdir of
                           Just TextFile -> onefilekensaku jknseplist sepc fdir
                           Just TextInFolder -> folderfileskensaku jknseplist sepc fdir
                           Nothing -> putStrLn "Target NG !!  Termination !!"



data Target = TextFile | TextInFolder



hantei_target :: FilePath -> Maybe Target
hantei_target fdir
 | (isPrefixOf "TXT." (reverse fdir)) || (isPrefixOf "txt." (reverse fdir)) = Just TextFile
 | dotposition fdir == 0 = Just TextInFolder
 | otherwise = Nothing





set_sepCount_sepInfo :: String -> (Int, Int, T.Text)
set_sepCount_sepInfo sepc =
   let
      sepcnt = read sepc
      sepcount = sepcnt - 1
      sepmretsu = replicate sepcount '\n'
   in
      (sepcnt, sepcount, T.pack sepmretsu)



onefilekensaku :: [[T.Text]] -> String -> FilePath -> IO()
onefilekensaku jknseplist sepc fdir = do
   filenames <- getDirectoryContents (takeDirectory fdir)
   day <- utctDay <$> getCurrentTime
   daytime <- utctDayTime <$> getCurrentTime
   let
      date = show day
      datetime = show daytime
      dir = takeDirectory fdir ++ "\\"

      (outFcommon, outFrcommon) = commonOfOutputfileName dir
      (outF, outFr) = outputfileName outFcommon outFrcommon day daytime

      dirfilenames = map (\x -> mconcat [dir, x]) filenames
   if (elem outF dirfilenames || elem outFr dirfilenames)
      then onefilekensaku jknseplist sepc fdir
      else do
         let
            sepCount_sepInfo = set_sepCount_sepInfo sepc

         fsjzenbunkensaku sepCount_sepInfo jknseplist dir outF outFr (1, fdir)
   let disp =  "Output : " ++ outF ++ " , " ++ outFr
   putStrLn disp



numberingTargetFilePathList :: FilePath -> FilePath -> [FilePath] -> [(Int, FilePath)]
numberingTargetFilePathList   outFcommon outFrcommon dirfilenames =
   let
      textFileList = getTextFileListInFolder dirfilenames
      targetFileList = [filepath | filepath <- textFileList, (not (isPrefixOf outFcommon filepath)) && (not (isPrefixOf outFrcommon filepath))]
   in
      reverse $ zip [1..] targetFileList



commonOfOutputfileName :: FilePath -> (FilePath, FilePath)
commonOfOutputfileName dir =
   let
      outFcommon = dir ++ "Tfzkbp1sfSELECT"
      outFrcommon = dir ++ "Tfzkbp1sfRVS"
   in
      (outFcommon, outFrcommon)



outputfileName :: FilePath -> FilePath -> Day -> DiffTime -> (FilePath, FilePath)
outputfileName outFcommon outFrcommon day daytime =
   let
      date = show day
      datetime = show daytime
      outF = outFcommon ++ date ++ datetime ++ ".TXT"
      outFr = outFrcommon ++ date ++ datetime ++ ".TXT"
   in
      (outF, outFr)



folderfileskensaku ::[[T.Text]] -> String -> FilePath -> IO()
folderfileskensaku jknseplist sepc fdir = do
   filenames <- getDirectoryContents fdir
   let
      dir = fdir ++ "\\"

      (outFcommon, outFrcommon) = commonOfOutputfileName dir

      dirfilenames = map (\x -> mconcat [dir, x]) filenames

      numberedTargetFilePathList = numberingTargetFilePathList outFcommon outFrcommon dirfilenames

      sepCount_sepInfo = set_sepCount_sepInfo sepc

   day <- utctDay <$> getCurrentTime
   daytime <- utctDayTime <$> getCurrentTime
   let
      (outF, outFr) = outputfileName outFcommon outFrcommon day daytime

   if (elem outF dirfilenames || elem outFr dirfilenames)
      then folderfileskensaku jknseplist sepc fdir
      else mapM_ (fsjzenbunkensaku sepCount_sepInfo jknseplist dir outF outFr) numberedTargetFilePathList
   let
     disp =  "Output : " ++ outF ++ " , " ++ outFr
   putStrLn disp



set_kensakuJouken :: T.Text -> T.Text -> [[T.Text]]
set_kensakuJouken joukens separator =
   let
       joukenlis = T.lines (mconcat [joukens, "\n", separator])

       prejknseplist = setjouken joukenlis separator [""]
   in
       map (\x -> filter (/= "") x) prejknseplist



getTextFileListInFolder ::  [FilePath] -> [FilePath]
getTextFileListInFolder filepathlist =
   [filepath | filepath <- filepathlist, let rfilepath = reverse filepath, (isPrefixOf "TXT." rfilepath) || (isPrefixOf "txt." rfilepath)]



fsjzenbunkensaku :: (Int,Int,T.Text) -> [[T.Text]] -> FilePath -> FilePath -> FilePath -> (Int, FilePath) -> IO ()
fsjzenbunkensaku (sepcnt, sepcount, sepmretsu) jknseplist dir outF outFr fn = do
   contents <- TIO.readFile (snd fn)
   let
      lcontents = del_fukkimoji_lines_contents contents sepmretsu

      sepdataOnlengthlist = replicate sepcount 0

      linelengthlist = lengthListOfEachLine lcontents

      numberedlinecontents = zip [1..] lcontents

      list_of_block_start_end =
         if sepcount == 0 then listOf_block_start_end_at_sepcount_0 linelengthlist 0 numberedlinecontents
                          else listOf_block_start_end linelengthlist sepdataOnlengthlist numberedlinecontents sepcount [""] 0

      ttl :: T.Text
      ttl = mconcat ["***   下記は、　" , (T.pack (snd fn)), "からの抽出です。******\n\n"]

      (select, rvs) = select_rvs jknseplist list_of_block_start_end

      hizukeList = listhizuke  1  [(0, "")]  lcontents

      ttlselectbb = ttl : (setsuzoku select hizukeList sepmretsu sepcount 1 (snd fn))

   outFapp ttlselectbb outF

   let
      ttlrvsbb = ttl : (setsuzoku rvs hizukeList sepmretsu sepcount 1 (snd fn))

   outFapp ttlrvsbb outFr



del_fukkimoji_lines_contents :: T.Text -> T.Text -> [T.Text]
del_fukkimoji_lines_contents contents sepmretsu =
   let
      cnts = mconcat [contents, sepmretsu]
      kyouseicnts = delfukkimoji (T.unpack cnts) ""
   in 
      T.lines kyouseicnts



delfukkimoji :: String -> String -> T.Text
delfukkimoji [] buf = T.pack $ reverse buf
delfukkimoji (x:xs) buf
 | x == '\r' = delfukkimoji xs buf
 | otherwise = delfukkimoji xs (x : buf)



lengthListOfEachLine :: [T.Text] -> [Int]
lengthListOfEachLine lconts =
   map T.length lconts



linenumberOfContents :: [T.Text] -> [Int]
linenumberOfContents lconts =
   let
      concount = length lconts
   in
      take concount [1..]



outFapp :: [T.Text] -> FilePath -> IO ()
outFapp outputdata outputF = do
   let
      func = writeoutF (T.concat outputdata)
   writeAppF outputF func



writeAppF fnam func =
   bracket (openFile fnam AppendMode)
      (\hdl -> hClose hdl)--成功終了時もこれが実行されてしまう。
      (\hdl -> func hdl)--成功時の実行内容。



writeoutF dat hdl = do
   TIO.hPutStr hdl dat



isHizuke::T.Text -> Bool
isHizuke xx = 
   let
       xxs = T.unpack xx
       nen = take 4 xxs
       p1 = xxs !! 4
       gatsu = (xxs !! 5) : (xxs !! 6) : []
       p2 = xxs !! 7
       pi = (xxs !! 8) : (xxs !! 9) : []
       p3 = xxs !! 10
   in
       if (isNen nen && isGatsu gatsu && isPi pi && p1 == '.' && p2 == '.' && p3 == '.')
          then True
          else False



isNen::String -> Bool
isNen nen = foldl (&&) True (map isDigit nen)


isGatsu::String -> Bool
isGatsu x = isDigit (x !! 0) && isDigit (x !! 1) && ((x !! 0) == '0' || (x !! 0) == '1')


isPi::String -> Bool
isPi x =  isDigit (x !! 0) && isDigit (x !! 1) && ((x !! 0) >= '0' && (x !! 0) <= '3')



listhizuke :: Int -> [(Int, T.Text)] -> [T.Text] -> [(Int, T.Text)]
listhizuke ban dd  [] = reverse dd
listhizuke ban dd (x:xs) =
  let
     isHzk = if (T.length x) < 11 then False
                                  else isHizuke x
  in
     if isHzk then listhizuke (ban+1) ((ban, x):dd) xs
              else listhizuke (ban+1) dd xs



dotposition :: FilePath -> Int
dotposition fn = case findIndex (== '.') fn of
   Just x -> x
   otherwise -> 0



select_rvs :: [[T.Text]] -> [([T.Text],Int,Int)] -> ([([T.Text],Int,Int)], [([T.Text],Int,Int)])
select_rvs jkn list_bc_s_e =
   let
      hanteilist = map (maching jkn) list_bc_s_e
      select = put_list_bc_s_eAtTrue hanteilist list_bc_s_e
      rvs = put_list_bc_s_eAtFalse hanteilist list_bc_s_e
   in
      (select, rvs)

 where
    maching :: [[T.Text]] -> ([T.Text],Int,Int) -> Bool
    maching jkn (bc,s,e) =
       let
          unlc = T.unlines bc
          aa = map (map (flip T.isInfixOf unlc)) jkn
          bb = map (\x -> any (==True) x) aa
       in
          not $ any (==False) bb

    put_list_bc_s_eAtTrue :: [Bool] -> [([T.Text],Int,Int)] -> [([T.Text],Int,Int)]
    put_list_bc_s_eAtTrue [] _ = []
    put_list_bc_s_eAtTrue (h:hs) (x:xs)
     | h == True = x : put_list_bc_s_eAtTrue hs xs
     | otherwise = put_list_bc_s_eAtTrue hs xs

    put_list_bc_s_eAtFalse :: [Bool] -> [([T.Text],Int,Int)] -> [([T.Text],Int,Int)]
    put_list_bc_s_eAtFalse [] _ = []
    put_list_bc_s_eAtFalse (h:hs) (x:xs)
     | h == False = x : put_list_bc_s_eAtFalse hs xs
     | otherwise = put_list_bc_s_eAtFalse hs xs



listOf_block_start_end_at_sepcount_0 :: [Int] -> Int   ->   [(Int, T.Text)] -> [([T.Text], Int, Int)]
listOf_block_start_end_at_sepcount_0 [] _ _ = []
listOf_block_start_end_at_sepcount_0 _ _ [] = []
listOf_block_start_end_at_sepcount_0 (x:xs) sepdataOnlength ((gyoban,linecontent):ys)
 | x == 0 = listOf_block_start_end_at_sepcount_0 xs sepdataOnlength ys
 | otherwise = ([linecontent], gyoban, gyoban) : listOf_block_start_end_at_sepcount_0 xs sepdataOnlength ys



--listOf_block_start_end
listOf_block_start_end :: [Int] -> [Int] -> [(Int, T.Text)] -> Int -> [T.Text] -> Int  -> [([T.Text], Int, Int)]
listOf_block_start_end [] _ _ _ _ _ = []
listOf_block_start_end _ _ [] _ _ _ = []
listOf_block_start_end lllist@(x:xs) sepdataOnlengthlist ((gyoban,linecontent):ys) sepcount chikusekiblock 0
   | isPrefixOf sepdataOnlengthlist lllist =
       listOf_block_start_end xs sepdataOnlengthlist ys sepcount [""] 0
   | gyoban == 1 =
      listOf_block_start_end xs sepdataOnlengthlist ys sepcount [linecontent] 1
   | gyoban == 2 =
      listOf_block_start_end xs sepdataOnlengthlist ys sepcount (mconcat [[""], [linecontent]]) 1
   | otherwise =
      listOf_block_start_end xs sepdataOnlengthlist ys sepcount [linecontent] (gyoban+sepcount-1)

listOf_block_start_end lllist@(x:xs) sepdataOnlengthlist ((gyoban,linecontent):ys) sepcount chikusekiblock startline
   | not (isPrefixOf sepdataOnlengthlist lllist) =
      listOf_block_start_end xs sepdataOnlengthlist ys sepcount (mconcat [chikusekiblock, [linecontent]]) startline
   | startline == 1 =
      (chikusekiblock, 1, gyoban-1):(listOf_block_start_end xs sepdataOnlengthlist ys sepcount [""] 0)
   | otherwise =
      ((drop (sepcount-1) chikusekiblock), startline, gyoban-1):(listOf_block_start_end xs sepdataOnlengthlist ys sepcount [""] 0)



setjouken :: [T.Text] -> T.Text -> [T.Text] -> [[T.Text]]
setjouken [] _ _ = [] 
setjouken (x:xs) sl buf
   |   T.isPrefixOf sl x == True  = buf:(setjouken xs sl [])
   |   T.isPrefixOf sl x == False = setjouken xs sl (mconcat [buf, [x]])



setsuzoku :: [([T.Text], Int, Int)] -> [(Int, T.Text)] -> T.Text -> Int -> Int -> FilePath -> [T.Text]
setsuzoku [] _ _ _ _ _ = []
setsuzoku ((b, s, e):xs) banbun sepmretsu spc ban ifl =
   if spc == 0 then (mconcat [(T.pack (show s)), " -- ", (T.pack (show e)), "  in  ＜", (T.pack ifl), "＞\n@",  (setHizuke banbun s), "\n", (T.pack (show ban)), "\n", (T.unlines b), sepmretsu, "\n"]):(setsuzoku xs banbun sepmretsu spc (ban+1) ifl)
               else (mconcat [(T.pack (show s)), " -- ", (T.pack (show e)), "  in  ＜", (T.pack ifl), "＞\n@",  (setHizuke banbun s), "\n", (T.pack (show ban)), "\n", (T.unlines b), sepmretsu]):(setsuzoku xs banbun sepmretsu spc (ban+1) ifl)
 where
      setHizuke::[(Int, T.Text)] -> Int -> T.Text
      setHizuke hizukeList s = (map snd  hizukeList) !! ((length (filter (<= s) (map fst hizukeList))) -1)
--関数setHizukeは、抽出文章の先頭番号と一致するかそれに一番近くて小さい行の日付行を選出している。