Makefile_dot_in's stats

# You need janet spork mpv yt-dlp
(import spork/base64)
(import spork/rawterm)
(import spork/utf8)
(import spork/sh)

# Spoilers!
(def questions "ICBbQHs6dXJsICJodHRwczovL3d3dy55b3V0dWJlLmNvbS93YXRjaD92PTdKTkZiTG1sU1VZIiA6YW5zd2VyICJMYWd0cmFpbiIgOmNvbW1lbnQgImhpIDozIn0KICAgQHs6dXJsICJodHRwczovL3d3dy55b3V0dWJlLmNvbS93YXRjaD92PXNiS1hpemo1V1U4IiA6YW5zd2VyICJUd28gWWVhcnMifQogICBAezp1cmwgImh0dHBzOi8vd3d3LnlvdXR1YmUuY29tL3dhdGNoP3Y9ZGxBZUVjVm5udm8iIDphbnN3ZXIgIll1a2FpIFlvdW5nIn0KICAgQHs6dXJsICJodHRwczovL3d3dy55b3V0dWJlLmNvbS93YXRjaD92PWhsZ2MzXzRXTDBNIiA6YW5zd2VyICJNb25vcmFsIn0KICAgQHs6dXJsICJodHRwczovL3d3dy55b3V0dWJlLmNvbS93YXRjaD92PWRQNHRfR0dsM0VzIiA6YW5zd2VyICJpbm5lciB1bml2ZXJzZSJ9CiAgIEB7OnVybCAiaHR0cHM6Ly93d3cueW91dHViZS5jb20vd2F0Y2g/dj16aGwtQ3MxLXNHNCIgOmFuc3dlciAiR2lvcmdpbyBieSBNb3JvZGVyIn0KICAgQHs6dXJsICJodHRwczovL3d3dy55b3V0dWJlLmNvbS93YXRjaD92PXRueVJCdVNzSXAwIiA6YW5zd2VyICJCYWthIG1pdGFpIGJ1dCBpdCdzIGluIHRva2kgcG9uYSJ9CiAgIEB7OnVybCAiaHR0cHM6Ly93d3cueW91dHViZS5jb20vd2F0Y2g/dj1QUmhqcVBDUEF0cyIgOmFuc3dlciAiWWFlZ2FraSJ9CiAgIEB7OnVybCAiaHR0cHM6Ly93d3cueW91dHViZS5jb20vd2F0Y2g/dj1hMERielVlLXI0USIgOmFuc3dlciAiSGVsaWtvcHRlciJ9CiAgIEB7OnVybCAiaHR0cHM6Ly93d3cueW91dHViZS5jb20vd2F0Y2g/dj1hNXVRTXdSTUhjcyIgOmFuc3dlciAiSW5zdGFudCBDcnVzaCJ9CiAgIEB7OnVybCAiaHR0cHM6Ly93d3cueW91dHViZS5jb20vd2F0Y2g/dj1sdXRxSnpHZlFNQSIgOmFuc3dlciAiZmVtaW5pbmUgYWRvcm5tZW50cyJ9CiAgIEB7OnVybCAiaHR0cHM6Ly93d3cueW91dHViZS5jb20vd2F0Y2g/dj1jUG5URmRNcFZzOCIgOmFuc3dlciAiSSBIYXZlbid0IEdvdCBBbnkgTGVncyJ9CiAgIEB7OnVybCAiaHR0cHM6Ly93d3cueW91dHViZS5jb20vd2F0Y2g/dj0tMXRYSlc5Q01aMCIgOmFuc3dlciAiVGhlcmUgSXMgQSBMaWdodCBUaGF0IE5ldmVyIEdvZXMgT3V0In0KICAgQHs6dXJsICJodHRwczovL3d3dy55b3V0dWJlLmNvbS93YXRjaD92PTFHYjJFVDk5TTNrIiA6YW5zd2VyICJrYWxhIGxpbGkgbGkga2FtYSB0YW4gbWEifQogICBAezp1cmwgImh0dHBzOi8vd3d3LnlvdXR1YmUuY29tL3dhdGNoP3Y9RVdITU5JQ3JDZjgiIDphbnN3ZXIgInN1c3N5IG1hY2hpbmUifQogICBAezp1cmwgImh0dHBzOi8vd3d3LnlvdXR1YmUuY29tL3dhdGNoP3Y9T3VpVEhNdXZxVDQiIDphbnN3ZXIgIkNhbmNpb24gZGVsIG1hcmlhY2hpIn0KICAgQHs6dXJsICJodHRwczovL3d3dy55b3V0dWJlLmNvbS93YXRjaD92PVlub3BIQ0wxSms4IiA6YW5zd2VyICJEcmFnb3N0ZWEgRGluIFRlaSJ9CiAgIEB7OnVybCAiaHR0cHM6Ly93d3cueW91dHViZS5jb20vd2F0Y2g/dj1IaFphSGY4UlA2ZyIgOmFuc3dlciAiVmVyaWRpcyBRdW8ifQogICBAezp1cmwgImh0dHBzOi8vd3d3LnlvdXR1YmUuY29tL3dhdGNoP3Y9aHF0aHNwU0taVjgiIDphbnN3ZXIgIklldmFuIHBvbGtrYSJ9CiAgIEB7OnVybCAiaHR0cHM6Ly93d3cueW91dHViZS5jb20vd2F0Y2g/dj1LNUtBYzVDb0N1ayIgOmFuc3dlciAiRGVybmllcmUgRGFuc2UifV0=")
(def questions (parse (base64/decode questions)))

(def man0 "_________")
(def man
  ["   |\n   |\n   |"
   "\n _____\n|     |\n|     |\n|     |\n-----"
   "\n   |\n   |"
   "\n  /"
   " \\"
   "\n /"
   "   \\"])


(def mpv (os/spawn ["mpv"
  "--input-ipc-server=/tmp/mpv-quiz.socket"
  "--keep-open=always"
  "--no-video"
  "--no-terminal"
  ;(map |(get $ :url) questions)] :p))

(rawterm/begin)
(print "In this quiz you will hear songs and have to guess their names hangman-style.")
(print "Please wait a bit for the playback to start.")
(print "If the program crashes, you may need to use pkill mpv and tput reset.")
(print "During the quiz, press ^C to exit.")
(prin "Press any key to continue: ")
(flush)
(rawterm/getch)
(def sock (net/connect :unix "/tmp/mpv-quiz.socket"))
(var points 0)
(var prevanswer "")
(each q questions
  (def {:url url :answer answer} q)
  (var wrong @"")
  (var correct @" '")
  (def testanswer (string/ascii-upper answer))
  (while (and (< (length wrong) (length man)) (not (string/check-set correct testanswer)))
    (prin "\x1b[2J\x1b[H")
    (printf "Previous answer: %s\n" prevanswer)
    (print man0)
    (print (string/join (slice man 0 (length wrong))))
    (prin "\n\n")
    (each char testanswer
      (cond
        (has-value? correct char) (prinf "%c" char)
        (= char 32) (prin " ")
        (= char 39) (prin "'")
        (prin "_"))
      (prin " "))
    (prin "\n\n")
    (prin "Guessed: ")
    (each char wrong (prinf "%c " char))
    (prin "\n\nEnter a character: ")
    (flush)
    (def char (get (string/ascii-upper (rawterm/getch)) 0))
    (when (= char 3)
      (rawterm/end)
      (os/proc-kill mpv)
      (os/exit))
    (when (and char
            (not= char 10)
            (not (has-value? correct char))
            (not (has-value? wrong char)))
      (if (has-value? testanswer char)
        (buffer/push correct char)
        (buffer/push wrong char))))
  (set (q :points) (- (length man) (length wrong)))
  (set prevanswer answer)
  (net/write sock "playlist-next force\nset pause no\n"))

(prin "\x1b[2J\x1b[H")
(printf "%-43s %-36s %-5s" "URL" "Answer" "Points")
(var total 0)
(each {:url url :answer answer :points points} questions
  (printf "%-43s %-36s %-5d" url answer points)
  (+= total points))

(printf "Total points: %d/%d. Goodbye." total (* (length questions) 7))
(rawterm/end)

(net/close sock)
(os/proc-wait mpv)

package require http
package require tls

http::register https 443 ::tls::socket
http::config -useragent {DiscordBot (https://codeguessing.gay, 1.0.0) songebot/1.0 (zzz)}

set song_list {
    https://www.youtube.com/watch?v=T5Cp55MvX54
    https://www.youtube.com/watch?v=eA2kiCScnI8&t=56s
    https://www.youtube.com/watch?v=vW9_5giCK1I
    https://www.youtube.com/watch?v=nXZuv1T8bfg
    https://www.youtube.com/watch?v=Lt-EbHhHD5Q
}

proc send {token channel_id} {
    set song [lindex $::song_list [expr {round(floor([llength $::song_list] * rand()))}]]
    set token [http::geturl https://discord.com/api/v10/channels/$channel_id/messages \
        -method POST \
        -query [subst {{"content": "$song"}}] \
        -headers [dict create \
                      content-type application/json \
                      authorization "Bot $token"
                 ]]

    set ret [http::data $token]
    http::cleanup $token
    set ret
}

array set arguments $argv
puts [send $arguments(-token) $arguments(-channel-id)]

# Then it waddled away...
# Waddle waddle

{- cabal:
build-depends: base, wuss, websockets, aeson, lens, text, monomer, text-show, stm
-}

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NamedFieldPuns #-}

module Main where

import Wuss
import Network.WebSockets (receiveData, sendTextData)
import Data.Aeson
import Control.Lens hiding ((.=))
import Data.Text (Text)
import Monomer
import Control.Concurrent.STM.TChan

import Control.Monad (forever)
import Data.Functor (void)
import Control.Concurrent (forkIO)
import Control.Concurrent.STM (atomically)
import qualified Monomer.Lens as L

data R
  = Connect { name :: Text }
  | Disconnect { name :: Text }
  | MessageR { name :: Text, content :: Text }
  deriving (Eq, Show)

instance FromJSON R where
  parseJSON = withObject "R" $ \o -> do
    reason <- o .: "reason"
    case reason :: Text of
      "connect" -> Connect <$> o .: "name"
      "disconnect" -> Disconnect <$> o .: "name"
      "message" -> MessageR <$> o .: "name" <*> o .: "content"
      _ -> fail $ "Unknown reason: " <> show reason

newtype S = S Text

instance ToJSON S where
  toJSON (S content) = object ["content" .= content]

data AppModel =
  AppModel
    { _messages :: [(Text, Text)]
    , _message :: Text
    , _users :: [Text]
    }
  deriving (Eq, Show)

data AppEvent
  = AppInit
  | AppWsEvent R
  | AppSendMessage
  | AppMessageSent
  | AppScrollUpdate ScrollStatus
  deriving (Eq, Show)


makeLenses 'AppModel

connectWs :: TChan S -> (AppEvent -> IO ()) -> IO ()
connectWs chan sendMessage =
  runSecureClient "codeguessing.gay" 443 "/73/ws" $ \con -> do
    void $ forkIO $ forever $ atomically (readTChan chan) >>= sendTextData con . encode
    forever $ receiveData con >>= mapM_ (sendMessage . AppWsEvent) . decode

buildUI
  :: WidgetEnv AppModel AppEvent
  -> AppModel
  -> WidgetNode AppModel AppEvent
buildUI _wenv model = widgetTree where
  widgetTree = hsplit_ [splitHandlePosV 0.9] (messageView, userlst)
  userlst = vscroll $ vstack $ map (`label_` [ellipsis]) $ model ^. users
  messageView = vstack_ [childSpacing]
    [ flip styleBasic [expandHeight 1]
      $ flip nodeKey "scroll"
      $ vscroll_
        [onChange AppScrollUpdate]
          $ vstack_ [childSpacing] $ reverse $
              map
                (\(sender, content) -> hstack_ [childSpacing]
                  [ label sender
                  , if content == ":cat_with_gua_pi_mao_hat_tone5:" then
                      image "cat.png" `styleBasic` [width 48, height 48]
                    else
                      label_ content [multiline]
                  ])
                (model ^. messages)
              & ix 0 %~ (`nodeKey` "first")
    , keystroke [("Enter", AppSendMessage)] $ textField message
    ] `styleBasic` [padding 10]

handleEvent
  :: TChan S
  -> WidgetEnv AppModel AppEvent
  -> WidgetNode AppModel AppEvent
  -> AppModel
  -> AppEvent
  -> [AppEventResponse AppModel AppEvent]
handleEvent chan wenv _node model evt = case evt of
  AppInit ->
    [Producer $ connectWs chan]
  AppWsEvent (MessageR {name, content}) ->
    [ Model (model & messages %~ ((name, content):))
    , responseMaybe $
        Message (WidgetKey "scroll") . ScrollTo . view L.viewport <$>
          nodeInfoFromKey wenv (WidgetKey "first")
    ]
  AppWsEvent (Connect {name}) ->
    [ Model (model & users %~ (name:)) ]
  AppWsEvent (Disconnect {name}) ->
    [ Model (model & users %~ filter (/=name)) ]
  AppSendMessage ->
    [ Task $ fmap (const AppMessageSent) $ atomically $ writeTChan chan $ S $ model ^. message
    , Model $ model & message .~ ""
    ]
  AppMessageSent ->
    []
  AppScrollUpdate (ScrollStatus {scrollRect = Rect x _ w h}) ->
    [Message (WidgetKey "scroll") $ Rect x (h+10) w (h+10)]


main :: IO ()
main = do
  chan <- atomically newTChan
  startApp model (handleEvent chan) buildUI config
  where
    config =
      [ appWindowTitle "Code Guessing"
      , appTheme darkTheme
      , appFontDef "Regular" "./Roboto-Regular.ttf"
      , appInitEvent AppInit
      ]
    model = AppModel
      { _messages = []
      , _message = ""
      , _users = []
      }

async function sendmoves(...lst) {
  const l = [];
  for (let { x = 0, y = 0, delay } of lst) {
    if (delay) await Promise.race([new Promise(resolve => setTimeout(() => resolve(), delay)), Promise.all(l)]);
    const xaxis = (x > 0) ? ["right", x] : ["left", -x];
    const yaxis = (y > 0) ? ["down",  y] : ["up",   -y];
    for (let [dir, length] of [xaxis, yaxis])
      for (let i = 0; i < length; ++i)
        l.push(fetch("/extra/game70", {method: "POST", body: JSON.stringify({dir}), headers}).then(r => r.json()));
  }

  let newState = await Promise.all(l)
    .then(rs => rs.reduce((a, b) => a.s > b.s ? a : b));
    
  if (newState !== undefined)
    renderGame(newState);
  return newState;
}

function findLocations(arr) {
  let plus, at, star;
  for (let y = 0; y < arr.length; ++y) {
    for (let x = 0; x < arr[y].length; ++x) {
     switch (arr[y][x]) {
        case "+": plus = [x, y]; break;
        case "@": at = [x, y]; break;
        case "*": star = [x, y]; break;
     }
    }
  }
  return {plus, at, star};
}

function vminus([x1, y1], [x2, y2]) { return [x1 - x2, y1 - y2]; }
function veq([x1, y1], [x2, y2]) { return x1 == x2 && y1 == y2; }

let x = false;

async function play() {
  while (!x) {
    const { plus, at: sat, star } = findLocations(screen.innerText.split("\n"));
    const at = [sat[0], sat[1]];
    const moves = [];
    const log = [];
    let n = 0;
    const x = x => { at[0] += x; n += Math.abs(x); moves.push({x}); };
    const y = y => { at[1] += y; n += Math.abs(y); moves.push({y}); };
    const delay = delay => { moves.push({delay: n * delay}); n = 0; };
    while (!veq(at, plus)) {
      const movevec = vminus(plus, at);
      if (star !== undefined) {
        const comet = vminus(star, at);
        const shenan = Math.sign(comet[0]) == Math.sign(movevec[0]) && Math.abs(comet[0]) <= Math.abs(movevec[0])
                    || Math.sign(comet[1]) == Math.sign(movevec[1]) && Math.abs(comet[1]) <= Math.abs(movevec[1]);
        const sxaxis = shenan && plus[0] == at[0] && at[0] == star[0];
        const syaxis = shenan && plus[1] == at[1] && at[1] == star[1];
        const interf = shenan && (plus[0] == star[0] || at[1] == star[1]);
        log.push({comet, shenan, sxaxis, syaxis, interf});
        if      (sxaxis) { x(plus[0] < 14 ? 1 : -1); delay(250);     }
        else if (syaxis) { y(plus[1] < 4  ? 1 : -1); delay(250);     }
        else if (interf) { y(movevec[1]); delay(150); x(movevec[0]); }
        else if (shenan) { x(movevec[0]); delay(150); y(movevec[1]); }
        else             { x(movevec[0]); y(movevec[1]);             }
      } else             { x(movevec[0]); y(movevec[1]);             }
    }
    const newstate = await sendmoves(...moves);
    console.log({plus, at, sat, star, moves, newstate, log, n});
    console.log(newstate.grid);
    await new Promise(resolve => setTimeout(() => resolve(), 10));
  }
}

(defun shitty-ries (n)
  (interactive "nThose who know: ")
  (with-temp-buffer
    (rename-buffer "Knowledge")
    (print `(= (- x ,n) 0) (current-buffer))
    (print `(= (- x (/ π ,(/ float-pi n))) 0) (current-buffer))
    (dotimes (i 10)
      (let ((r (+ n (random 0.01))) ; for increased fun
            (a (random))
            (y (random)))
        (print `(= (+ (* ,a (^ x 2)) (* ,(- (+ y r)) x) ,(* y r)) 0) (current-buffer))))
    (print-buffer)))
        
    

#!/home/olus2000/programy/smalltalk-3.2/gst

Object subclass: CipherCracker [
    | corpusBag inputBag count tbl |
    <comment: 'I crack subtitution ciphers ^_^'>

    CipherCracker class >> new [
        | r |
        r := super new.
        r init.
        ^r
    ]
    
    init [
        <category: 'initialization'>
        corpusBag := Bag new.
        inputBag := Bag new.
        count := 0.
    ]

    learn: corpus [
        <category: 'processing'>
        <comment: 'I update the cracker to expect text similar to the one provided.'>
        corpus do: [:c | c isLetter ifTrue: [corpusBag add: c asLowercase]].
    ]

    prescan: input [
        <category: 'processing'>
        <comment: 'I learn the frequency of letters in the input.'>
        input do: [:c | c isLetter ifTrue: [inputBag add: c asLowercase]].
    ]

    beforeCrack [
        <category: 'processing'>
        tbl := LookupTable new.
        inputBag sortedByCount
            with: corpusBag sortedByCount
            do: [:i :c | tbl at: i value put: c value].
    ]

    crack: string [
        <category: 'processing'>
        <comment: 'I cracka da string.'>
        count := count + 1.
        ^(string collect: [:c | c isUppercase
                              ifTrue: [(tbl at: c asLowercase ifAbsent: [c asLowercase]) asUppercase]
                              ifFalse: [tbl at: c ifAbsent: [c]]
                          ]) asString
    ]

    stats [
        <category: 'statistics'>
        ^'BORN TO SPAM
WORLD IS A MJAU
鬼神 Love Em All %1
I am l​ouna ^_^
' % { count }
    ]    
]

Dictionary extend [
    at: key ifAbsent: absent ifPresent: present [
        present value: (self at: key ifAbsent: [^absent value])
    ]
]
FileStream class extend [
    withOpen: fn mode: m do: block [
        | f |
        f := self open: fn mode: m.
        [block value: f] ensure: [f close].
    ]

    withOpen: fn1 mode: m1 and: fn2 mode: m2 do: block [
        | f1 f2 |
        f1 := self open: fn1 mode: m1.
        f2 := self open: fn2 mode: m2.
        [block value: f1 value: f2] ensure: [f1 close. f2 close].
    ]
]

Object subclass: Program [
    | input output corpus |

    arguments := LookupTable new
                 at: $c put: #corpus:;
                 at: $i put: #input:;
                 at: $o put: #output:;
                 yourself.
   
    corpus: filename [corpus := filename]
    input:  filename [input  := filename]
    output: filename [output := filename]

    run [
        | err cracker |
        err := false.
        Smalltalk arguments: '-c: -i: -o:'
                  do: [:name :arg | arguments
                                  at: name
                                  ifAbsent: [err := true]
                                  ifPresent: [:sel | self perform: sel with: arg].
                      ]
                  ifError: [^self usage].
        err ifTrue: [^self usage].
        corpus ifNil: [^self usage].
        input ifNil: [^self usage].
        output ifNil: [^self usage].
        
        cracker := CipherCracker new.
        FileStream withOpen: corpus
                   mode: FileStream read
                   do: [:f | f linesDo: [:l | cracker learn: l]].

        FileStream withOpen: input
                   mode: FileStream read
                   and: output
                   mode: FileStream write
                   do: [:in :out |
                        in linesDo: [:line | cracker prescan: line].
                        cracker beforeCrack.
                        in reset.
                        in linesDo: [:line | out << (cracker crack: line); nl]
                       ].
        cracker stats displayNl.
    ]

    usage [
        FileStream stderr << 'cracker.st -c CORPUS -i INPUT -o OUTPUT'; nl.
        ObjectMemory quit: 2
    ]
]

Program new run