bad-scripts/melt-change-resolution.hs

{-

don't use this script if you can help it!

this is a really bad script that could just as well be written
in something like sed; i did it in haskell just because and
had no time to make something sensible instead. it kinda works
for a few effects that i needed. except when it doesn't

-}

{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE LambdaCase #-}

module Main where

import Control.Monad (join)
import Data.Semigroup
import Data.List
import Data.Char

import Debug.Trace

splitOn p s = (takeWhile p s, dropWhile p s)

replaceOnce :: String -> String -> String -> (String, String)
replaceOnce a b = \case
  "" -> ("","")
  s@(x:xs) ->
    let
      len = length a
    in if take len s == a then
      (b, drop len s)
    else
      ([x], xs)

replace :: String -> String -> String -> String
replace a b = \case
  "" -> ""
  s ->
    let
      (ys,xs) = replaceOnce a b s
    in
      ys <> replace a b xs

processOnce scale s =
  let
    (fr,recti) = splitOn (/= '=') s
    rect = drop 1 recti
    nums :: [Double]
    nums = fmap read . words $ rect
    nums' = take 4 nums
    rest = drop 4 nums
    nums'' = fmap ((*scale) . floor) nums'
    res = traceShowId $ (unwords . fmap show $ nums'') ++ " " ++ unwords (fmap show rest)
  in
    fr <> "=" <> res

processRectVal scale = \case
  "" -> ""
  s ->
    let
      (x,xs) = splitOn (/= ';') s
    in
      processOnce scale x <> ";" <> processRectVal scale (drop 1 xs)

singletonLists = foldr ((:).(:[])) []

interMix :: [[a]] -> [[a]] -> [a]
interMix (i:ins) (m:ms) = m <> i <> interMix ins ms
interMix [] ms = join ms
interMix ins [] = []

cutBy _ [] = []
cutBy f l =
  let
    (x,xs) = break f l
  in
    [x] <> cutBy f (drop 1 xs)

isNumberChar x = isNumber x || x == '-'

keepFrame f s =
  case cutBy (== '=') s of
    [x] -> f x
    [k,x] -> k <> "=" <> f x

processGeomVal scale s =
  let
    sections = traceShowId $ cutBy (== ';') s
  in
    intercalate ";" . fmap (keepFrame $ processGeomOneVal scale) $ sections

dropEither :: Either a a -> a
dropEither (Left x) = x
dropEither (Right x) = x

processGeomOneVal scale s =
  let

    numss = traceShowId $ cutBy (\c -> not $ isNumberChar c || c == '.' || c == '%') s
    numsd :: [Either String Double]
    numsd = fmap (\ s -> if last s == '%' then Left s else Right (read s)) numss
    nums = fmap (fmap floor) numsd
    nums' = fmap (fmap (* scale)) (take 4 nums) <> drop 4 nums
    sss = fmap (dropEither . fmap show) nums'
    -- nums' = fmap (\case { Left pcs -> pcs ; Right x -> show (x * scale) }) (take 4 nums) <> fmap drop 4 nums
  in
    traceShowId $ interMix (singletonLists "    ") sss -- . fmap show $ nums'

processLine (w,h) (w',h') s =
  if "<profile" `isInfixOf` s then
    replace (show $ show w) (show $ show w') .
    replace (show $ show h) (show $ show h') $ s
  else if "<property name=\"rect\">" `isInfixOf` s then
    let
      (pref,ns) = splitOn (not . isNumberChar) s
      (val,suff) = splitOn (/= '<') ns
    in
      pref <> processRectVal (w' `div` w) val <> suff
  else if "<property name=\"transition.geometry\">" `isInfixOf` s || "<property name=\"geometry\">" `isInfixOf` s then
    let
      (pref,ns) = splitOn (not . isNumberChar) s
      (val,suff) = splitOn (/= '<') ns
    in
      pref <> processGeomVal (w' `div` w) val <> suff
  else if any (\w -> ("<property name=\""<>w<>"\">") `isInfixOf` s) ["left", "top", "bottom", "right"] then
    let
      (pref,ns) = splitOn (not . isNumberChar) s
      (val,suff) = splitOn (/= '<') ns
    in
      pref <> processGeomOneVal (w' `div` w) val <> suff
  else if "kdenlive:originalurl" `isInfixOf` s then
    replace "kdenlive:originalurl" "resource" s
  else if "proxy" `isInfixOf` s then
    ""
  else
    s

changeRes wh wh' src dst = do
  source <- lines <$> readFile src
  writeFile dst . unlines . fmap (processLine wh wh') $ source

-- usage example..
main = changeRes (160,90) (960,540) "proc.kdenlive" "proc_r.kdenlive"