misc: add more scripts

misc/Alliterations.hs

@@ -0,0 +1,56 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+import Control.Arrow ((>>>), (&&&), (***))
+import Data.Char (isPunctuation)
+import Data.List
+import Options.Applicative
+import Text.Printf
+import qualified Data.Text as T 
+import qualified Data.Text.IO as T
+
+import Stopwords
+
+slidingWindow :: Int -> [a] -> [[a]]
+slidingWindow n xs 
+  | n > length xs = []
+  | otherwise = take n xs : slidingWindow n (tail xs)
+
+alliterations :: Language -> T.Text -> [T.Text]
+alliterations language = 
+  cleanUp language
+  >>> filter containsAlliteration >>>
+  map (T.intercalate " ") 
+
+cleanUp language = 
+  T.filter (not.isPunctuation) 
+  >>> T.toLower 
+  >>> T.words 
+  >>> filter (`notElem` stopwords language) 
+  >>> slidingWindow 2 
+
+containsAlliteration :: [T.Text] -> Bool
+containsAlliteration = map T.head >>> ((nub >>> length) &&& length) >>> uncurry (<)
+
+measure :: Num a => Language -> T.Text -> (a, a)
+measure language = (alliterations language &&& cleanUp language) >>> (genericLength *** genericLength) 
+
+data Mode = Alliterations | Statistics
+
+mode :: Parser (Language, Mode)
+mode = 
+  (,) 
+  <$> ((English <$ switch (long "english" <> help "Cut out english stopwords"))
+      <|> (German <$ switch (long "german" <> help "Cut out german stopwords"))
+      <|> pure NoLanguage)
+  <*> ((Alliterations <$ switch (long "alliterations" <> short 'a' <> help "List all alliterations"))
+      <|> (Statistics <$ switch (long "statistics" <> short 's' <> help "Show statistics (quota)")))
+
+main :: IO ()
+main = execParser options >>= \(language, mode) -> 
+  case mode of
+    Alliterations ->
+      T.interact $ T.unlines . alliterations language 
+    Statistics -> T.interact $ \text ->
+      let (als, ws) = measure language text :: (Int, Int)
+       in T.pack (printf "Bigrams found: %u\nAlliterations found: %u\n\n%.2f%%\n" ws als (100 * fromIntegral als/fromIntegral ws :: Double))
+  where options = info (mode <**> helper) (fullDesc <> progDesc "finds alliterations and there density in German texts")

misc/Clock.hs

@@ -0,0 +1,37 @@
+module Clock where
+
+newtype Angle = Angle
+  { degrees :: Double
+  }
+
+instance Show Angle where
+  show alpha = show (degrees alpha) ++ "°"
+
+data Clock = Clock
+  { hourHand :: Angle
+  , minuteHand :: Angle
+  }
+
+instance Show Clock where
+  show (Clock h m) = show (h, m)
+
+data Time = Time
+  { hour :: Int
+  , minute :: Int
+  }
+
+time :: Int -> Int -> Time
+time h m = Time (h `mod` 12) (m `mod` 60)
+
+instance Show Time where
+  show (Time h m) = show h ++ ":" ++ (if m < 10 then "0" else "") ++ show m
+
+toClock :: Time -> Clock
+toClock (Time h m) = Clock (Angle $ 30 * h' + m' / 2) (Angle $ m' * 6)
+  where
+    h' = fromIntegral h
+    m' = fromIntegral m
+
+fromClock :: Clock -> Time
+fromClock (Clock (Angle h) (Angle m)) =
+  Time (round $ (h - m / 2) / 30) (round $ m / 6)

misc/ETIN.hs

@@ -0,0 +1,84 @@
+{-# LANGUAGE OverloadedStrings #-}
+import Data.Text (Text)
+import qualified Data.Text as Text
+
+isConsonant :: Char -> Bool
+isConsonant = flip elem ("BCDFGHJKLMNPQRSTVWXYZ" :: String)
+
+isVowel :: Char -> Bool
+isVowel = flip elem ("AEIOU" :: String)
+
+serialize :: Text -> Text
+serialize =
+  Text.filter (\c -> isConsonant c || isVowel c) .
+  Text.replace "Ä" "AE" .
+  Text.replace "Ö" "OE" .
+  Text.replace "Ü" "UE" .
+  Text.replace "ß" "SS" . Text.replace "SCH" "Y" . Text.toUpper
+
+data Person =
+  Person
+  { lastName :: Text
+  , firstName :: Text
+  , dateOfBirth :: (Int, Int, Int)
+  }
+
+serializeName :: Text -> Text
+serializeName n =
+  Text.pack $
+  take 4 $ filter isConsonant n' <> reverse (filter isVowel n') <> repeat 'X'
+  where
+    n' = Text.unpack $ serialize n
+
+etin :: Person -> Text
+etin (Person last first (y, m, d)) =
+  let etin' =
+        serializeName last <> serializeName first <> Text.pack (last2 (show y)) <>
+        Text.singleton (encode (m - 1)) <>
+        Text.pack (fill0 (show d))
+   in etin' <> Text.singleton (encode $ checksum $ Text.unpack etin')
+  where
+    last2 = until (\x -> length x == 2) tail
+    fill0 = until (\x -> length x == 2) ('0' :)
+    encode = (!!) ['A' .. 'Z']
+    checksum x = sum (zipWith value x (cycle [False, True])) `mod` 26
+
+value :: Char -> Bool -> Int
+value x = case x of
+  '0' -> eo 0 1
+  '1' -> eo 1 0
+  '2' -> eo 2 5
+  '3' -> eo 3 7
+  '4' -> eo 4 9
+  '5' -> eo 5 13
+  '6' -> eo 6 15
+  '7' -> eo 7 17
+  '8' -> eo 8 19
+  '9' -> eo 9 21
+  'A' -> eo 0 1
+  'B' -> eo 1 0
+  'C' -> eo 2 5
+  'D' -> eo 3 7
+  'E' -> eo 4 9
+  'F' -> eo 5 13
+  'G' -> eo 6 15
+  'H' -> eo 7 17
+  'I' -> eo 8 19
+  'J' -> eo 9 21
+  'K' -> eo 10 2
+  'L' -> eo 11 4
+  'M' -> eo 12 18
+  'N' -> eo 13 20
+  'O' -> eo 14 11
+  'P' -> eo 15 3
+  'Q' -> eo 16 6
+  'R' -> eo 17 8
+  'S' -> eo 18 12
+  'T' -> eo 19 14
+  'U' -> eo 20 16
+  'V' -> eo 21 10
+  'W' -> eo 22 22
+  'X' -> eo 23 23
+  'Y' -> eo 24 24
+  'Z' -> eo 25 25
+  where eo e o b = if b then e else o

misc/Nolindrom.hs

@@ -0,0 +1,14 @@
+module Nolindrom where
+
+nolindrom :: Int -> Integer -> Bool
+nolindrom i n
+  | i >= 100 = True
+  | otherwise =
+    let r = read . reverse . show $ n
+        n' = r + n
+     in not (palindrome n') && nolindrom (succ i) n'
+  where
+    palindrome x =
+      let s = show x
+       in s == reverse s
+

misc/PhoneNo.hs

@@ -0,0 +1,19 @@
+{-# LANGUAGE LambdaCase #-}
+import Data.Char
+
+letters = \case
+  2 -> "ABC"
+  3 -> "DEF"
+  4 -> "GHI"
+  5 -> "JKL"
+  6 -> "MNO"
+  7 -> "PQRS"
+  8 -> "TUV"
+  9 -> "WXYZ"
+  _ -> []
+
+main :: IO ()
+main = interact $ unlines . possibleWords . digitsOf
+  where
+    possibleWords = mapM letters
+    digitsOf = map digitToInt . filter isDigit

misc/Set.hs

@@ -0,0 +1,145 @@
+{-# LANGUAGE TypeSynonymInstances, TypeFamilies #-}
+module Set where
+
+import Data.Char
+import Data.Complex
+import qualified GHC.Exts as Exts
+
+import Prelude hiding (filter)
+import qualified Prelude
+import Data.Functor.Contravariant
+import qualified Data.Functor.Contravariant.Divisible as Divisible
+import Data.Isomorphism
+
+liftP :: (Bool -> Bool) -> Predicate a -> Predicate a
+liftP op p = Predicate $ op <$> getPredicate p
+
+liftP2 :: (Bool -> Bool -> Bool) -> Predicate a -> Predicate a -> Predicate a
+liftP2 op p q = Predicate $ op <$> getPredicate p <*> getPredicate q
+
+type Set = Predicate
+
+instance (Eq a) => Exts.IsList (Set a) where
+    type Item (Set a) = a
+    fromList = fromFoldable
+    toList = undefined
+
+(\\) :: Set a -> Set a -> Set a
+(\\) = difference
+
+(\/) :: Set a -> Set a -> Set a
+(\/) = union
+
+(/\) :: Set a -> Set a -> Set a
+(/\) = intersection
+
+cantor :: (a -> Set a) -> Set a
+cantor = Predicate . (<*>) notMember
+
+cartesian :: Set a -> Set b -> Set (a, b)
+cartesian = Divisible.divided
+
+complement :: Set a -> Set a
+complement = liftP not
+
+containing :: a -> Set (Set a)
+containing = Predicate . member
+
+delete :: (Eq a) => a -> Set a -> Set a
+delete x m = m \\ singleton x
+
+difference :: Set a -> Set a -> Set a
+difference = liftP2 (\x y -> x && not y)
+
+disjointUnion :: Set a -> Set b -> Set (Either a b)
+disjointUnion = Divisible.chosen
+
+empty :: Set a
+empty = Predicate $ const False
+
+universal :: Set a
+universal = mempty
+
+filter :: (a -> Bool) -> Set a -> Set a
+filter f m = Predicate $ (&&) <$> getPredicate m <*> f
+
+fromFoldable :: (Foldable t, Eq a) => t a -> Set a
+fromFoldable = Predicate . flip elem
+
+insert :: (Eq a) => a -> Set a -> Set a
+insert = union . singleton
+
+intersection :: Set a -> Set a -> Set a
+intersection = liftP2 (&&)
+
+member :: a -> Set a -> Bool
+member = flip getPredicate
+
+notMember :: a -> Set a -> Bool
+notMember = (not .) . member
+
+partition :: (a -> Bool) -> Set a -> (Set a, Set a)
+partition f m = (filter f m, filter (not . f) m)
+
+singleton :: (Eq a) => a -> Set a
+singleton = Predicate . (==)
+
+split :: (Ord a) => a -> Set a -> (Set a, Set a)
+split pivot m = (filter (< pivot) m, filter (> pivot) m)
+
+splitMember :: (Ord a) => a -> Set a -> (Set a, Bool, Set a)
+splitMember pivot m = let (ls, gs) = split pivot m in (ls, member pivot m, gs)
+
+toList :: (Enum a, Bounded a) => Set a -> [a]
+toList m = Prelude.filter (getPredicate m) [minBound .. maxBound]
+
+union :: Set a -> Set a -> Set a
+union = liftP2 (||)
+
+unions :: (Foldable t) => t (Set a) -> Set a
+unions = foldr union empty
+
+naturals :: (Ord a, Integral a) => Set a
+naturals = Predicate (>= 0)
+
+reals :: (Real a) => Set a
+reals = universal
+
+rationals :: (Fractional a) => Set a
+rationals = universal
+
+integers :: (Integral a) => Set a
+integers = universal
+
+complexes :: (Real a) => Set (Complex a)
+complexes = universal
+
+mapIso :: Iso (->) a b -> Set a -> Set b
+mapIso = contramap . project
+
+digit :: Iso (->) Int Char
+digit = Iso intToDigit digitToInt
+
+casePreserving :: (String -> String) -> String -> String
+casePreserving f = applyCasing <$> map isUpper <*> f
+    where applyCasing = zipWith (bool toUpper toLower)
+          bool x y b = if b then x else y
+
+main = do
+  let sampleSet = fromFoldable [0 .. 9]
+  let digitSet = mapIso digit sampleSet
+  print (toList digitSet)
+
+shorten :: String -> String
+shorten word
+  | n <= 10 = word
+  | otherwise = [head word] ++ show (n - 2) ++ [last word]
+  where
+    n = length word
+
+lev :: (Eq a) => [a] -> [a] -> Int
+lev [] ys = length ys
+lev xs [] = length xs
+lev xxs@(x:xs) yys@(y:ys)
+  | x == y = lev xs ys
+  | otherwise = 1 + minimum [lev xs yys, lev xxs ys, lev xs ys]

misc/Sierpinski.lhs

@@ -0,0 +1,37 @@
+> import Diagrams.Backend.SVG.CmdLine
+
+> {-# LANGUAGE NoMonomorphismRestriction #-}
+> import Diagrams.Prelude
+
+#### Brent's Original Code
+> -- sierpinski 1 = triangle 1
+> -- sierpinski n =     s
+> --                  ===
+> --               (s ||| s) # centerX
+> --   where s = sierpinski (n-1)
+
+#### Code to change color at each level
+##### (Technically this is the complement of the Sierpinski triangle)
+> import Diagrams.Prelude
+> import Data.Colour.Palette.BrewerSet
+>
+> clrs :: [Colour Double]
+> clrs = brewerSet Purples 9
+>
+> sierpinski :: Int -> [Colour Double] -> Diagram B
+> sierpinski n c = go n <> triangle (2^n) # fc (clrs !! 0) # lw none
+>   where
+>     clrs = if null c then repeat black else cycle c
+>     go n
+>       | n == 1    = t1 # fc (clrs !! 1)
+>       | otherwise = appends tri (zip vecs (replicate 3 sierp))
+>       where
+>         tri   = scale (2 ^ (n-1)) $ t1 # fc (clrs !! (n+1))
+>         vecs  = [unitY, (rotateBy (-1/12) unitX), (rotateBy (1/12) unit_X)]
+>         sierp = go (n-1)
+>         t1    = triangle 1 # reflectY
+>
+> example =  sierpinski 7 clrs # lw none # center # frame 2
+
+
+> main = mainWith (example :: Diagram B)

misc/init.sh

@@ -0,0 +1,99 @@
+#!/usr/bin/env nix-shell
+#! nix-shell -i bash -p cryptsetup gptfdisk jq libxfs
+set -xefuo pipefail
+
+disk=$1
+
+if mount | grep -q "$disk"; then
+  echo "target device is already mounted, bailout"
+  exit 2
+fi
+
+bootdev="$disk"2
+luksdev="$disk"3
+luksmap=/dev/mapper/crypted
+
+# vgname=vgname
+
+
+rootdev="$luksmap"
+# homedev=/dev/mapper/vgname-home
+
+read -p "LUKS Password: " lukspw
+
+#
+# partitioning
+#
+
+# http://en.wikipedia.org/wiki/GUID_Partition_Table
+# undo:
+#   dd if=/dev/zero bs=512 count=34 of=/dev/sda
+# TODO zero last 34 blocks (lsblk -bno SIZE /dev/sda)
+if ! test "$(blkid -o value -s PTTYPE "$disk")" = gpt; then
+  sgdisk -og "$disk"
+  sgdisk -n 1:2048:4095 -c 1:"BIOS Boot Partition" -t 1:ef02 "$disk"
+  sgdisk -n 2:4096:+1G -c 2:"EFI System Partition" -t 2:ef00 "$disk"
+  sgdisk -n 3:0:0 -c 3:"LUKS container" -t 3:8300 "$disk"
+fi
+
+if ! test "$(blkid -o value -s PARTLABEL "$luksdev")" = "LUKS container"; then
+  echo zonk2
+  exit 23
+fi
+
+if ! cryptsetup isLuks "$luksdev"; then
+  # aes xts-plain64
+  echo -n "$lukspw" | cryptsetup luksFormat "$luksdev" - \
+      -h sha512 \
+      --iter-time 5000
+fi
+
+if ! test -e "$luksmap"; then
+  echo "$lukspw" | cryptsetup luksOpen "$luksdev" "$(basename "$luksmap")" -
+fi
+
+# if ! test "$(blkid -o value -s TYPE "$luksmap")" = LVM2_member; then pvcreate "$luksmap"; fi
+
+# if ! vgdisplay -s "$vgname"; then vgcreate "$vgname" "$luksmap"; fi
+
+# lvchange -a y /dev/mapper/"$vgname"
+
+# if ! test -e "$rootdev"; then lvcreate -L 3G -n root "$vgname"; fi
+
+
+# formatting
+#
+
+if ! test "$(blkid -o value -s TYPE "$bootdev")" = vfat; then
+  mkfs.vfat "$bootdev"
+fi
+
+if ! test "$(blkid -o value -s TYPE "$rootdev")" = ext4; then
+  mkfs.ext4 "$rootdev"
+fi
+
+if ! test "$(lsblk -n -o MOUNTPOINT "$rootdev")" = /mnt; then
+  mkdir -p /mnt
+  mount "$rootdev" /mnt
+fi
+if ! test "$(lsblk -n -o MOUNTPOINT "$bootdev")" = /mnt/boot; then
+  mkdir -m 0000 -p /mnt/boot
+  mount "$bootdev" /mnt/boot
+fi
+
+#
+# dependencies for stockholm
+#
+
+# TODO: get sentinal file from target_path
+mkdir -p /mnt/var/src
+touch /mnt/var/src/.populate
+
+#
+# print all the infos
+#
+
+gdisk -l "$disk"
+lsblk "$disk"
+
+echo READY.

misc/sort.hs

@@ -0,0 +1,27 @@
+{-# LANGUAGE LambdaCase #-}
+import           Control.Monad                  ( forM_ )
+import           Data.Char                      ( toLower )
+import           System.Environment             ( getArgs )
+
+insertionSortM :: Monad f => (a -> a -> f Ordering) -> [a] -> f [a]
+insertionSortM cmp = foldr ((=<<) . insertByM cmp) (pure [])
+ where
+  insertByM cmp x = \case
+    []           -> pure [x]
+    yys@(y : ys) -> cmp x y >>= \case
+      GT -> (y :) <$> insertByM cmp x ys
+      _  -> pure (x : yys)
+
+ask :: Show a => a -> a -> IO Ordering
+ask a b = do
+  putStr (show a ++ " > " ++ show b ++ "? (y/n) ")
+  map toLower <$> getLine >>= \case
+    'y' : _ -> return GT
+    _       -> return LT
+
+main :: IO ()
+main = do
+  argv   <- getArgs
+  sorted <- insertionSortM ask argv
+  forM_ (zip [1 ..] sorted)
+    $ \(place, thing) -> putStrLn (show place ++ ". " ++ show thing)

misc/sort.py

@@ -0,0 +1,25 @@
+#!/usr/bin/env python3
+import sys
+
+
+def insertion_sort(arr, compare=lambda x, y: x < y):
+    for i in range(1, len(arr)):
+        key = arr[i]
+        j = i - 1
+        while compare(key, arr[j]):
+            arr[j + 1] = arr[j]
+            j -= 1
+        arr[j + 1] = key
+    return arr
+
+
+def manual_compare(x, y):
+    reply = input("{} <= {} (y/n)? ".format(x, y))
+    return reply.lower() == "y"
+
+
+if __name__ == "__main__":
+    lines = sys.argv[1:]
+    sorted_lines = insertion_sort(lines, manual_compare)
+    for i, line in enumerate(lines):
+        print(i + 1, line)