Browse Source

AAAAAAAAA WHAT THE FUCK

master
Hazel Levine 1 year ago
parent
commit
af6e82863c
Signed by: hazel
GPG Key ID: 1884029A28789A62
  1. 70
      .gitignore
  2. 1
      bin/README.md
  3. 93
      bin/get-challenge
  4. 15
      bin/get-input
  5. 15
      day1.rkt
  6. 119
      lib/aoc.rkt
  7. 103
      lib/common.rkt
  8. 15
      tmpl.rkt

70
.gitignore vendored

@ -0,0 +1,70 @@
# ---> Racket
# gitignore template for the Racket language
# website: http://www.racket-lang.org/
# DrRacket autosave files
*.rkt~
*.rkt.bak
\#*.rkt#
\#*.rkt#*#
# Compiled racket bytecode
compiled/
*.zo
# Dependency tracking files
*.dep
# ---> Emacs
# -*- mode: gitignore; -*-
*~
\#*\#
/.emacs.desktop
/.emacs.desktop.lock
*.elc
auto-save-list
tramp
.\#*
# Org-mode
.org-id-locations
*_archive
# flymake-mode
*_flymake.*
# eshell files
/eshell/history
/eshell/lastdir
# elpa packages
/elpa/
# reftex files
*.rel
# AUCTeX auto folder
/auto/
# cask packages
.cask/
dist/
# Flycheck
flycheck_*.el
# server auth directory
/server/
# projectiles files
.projectile
# directory configuration
.dir-locals.el
# network security
/network-security.data
.envrc
.status.rktd
viz/*

1
bin/README.md

@ -0,0 +1 @@
these are stolen from [haskal's stuff](https://git.lain.faith/haskal/aoc2020/src/branch/aoc2020/scripts). go look there

93
bin/get-challenge

@ -0,0 +1,93 @@
#!/usr/bin/env racket
#lang racket
(require "../lib/aoc.rkt"
ansi-color
html
xml)
(define erase-line "\033[K")
;; finds a given element of an xexpr
(define (find-element el doc)
(match doc
[(list (== el) _ ...) doc]
[(list tag attrs children ...)
(ormap (curry find-element el) children)]
[_ #f]))
(struct style-ast [fg bg fs children] #:transparent)
;; convert xexpr tree to an ast with lower-level styling
(define (xexpr->style-ast doc)
(match doc
[(? string?) (style-ast #f #f #f doc)]
[(list (or 'script 'form) _ ...) #f]
[(list-no-order 'p (list 'span (list-no-order '(class "share")) _ ...) _ ...) #f]
[(list 'li _ children ...)
(define out-children (filter identity (map xexpr->style-ast children)))
(style-ast #f #f #f (cons (style-ast #f #f #f "- ") out-children))]
[(list tag attrs children ...)
(define-values [fg bg fs]
(match* (tag attrs)
[('main _) (values #f #f #f)]
[('article _) (values #f #f #f)]
[('p (list-no-order '(class "day-success") _ ...)) (values 'yellow #f 'bold)]
[('p _) (values #f #f #f)]
[('pre _) (values #f #f #f)]
[('h2 _) (values #f #f 'bold)]
[('ul _) (values #f #f #f)]
[('a _) (values 'green #f #f)]
[('code _) (values 'white 234 #f)]
[('span _) (values #f #f #f)]
[('em (list-no-order '(class "star") _ ...)) (values 'yellow #f 'bold)]
[('em _) (values #f #f 'bold)]
[(_ _)
(printf "warning: unhandled ~a ~a\n" tag attrs)
(values #f #f #f)]))
(define inner-children (filter identity (map xexpr->style-ast children)))
(define new-children
(if ((or/c 'h2 'pre 'p) tag)
(let ([nls (list (style-ast #f #f #f "\n") (style-ast #f #f #f "\n"))])
(append nls inner-children nls))
inner-children))
(style-ast fg bg fs new-children)]))
(define (output-style-ast ast)
(define num-newlines (make-parameter #f))
(define (helper ast [prev-bg ""] [prev-fg ""])
(match-define (style-ast fg bg fs children) ast)
(when bg (background-color bg))
(when fg (foreground-color fg))
(match children
["\n"
(unless (or (false? (num-newlines)) (>= (num-newlines) 2))
(num-newlines (add1 (num-newlines)))
(display "\n"))]
[(? string? str)
(num-newlines 0)
(if (string-contains? str "\n")
(for ([i (in-naturals)] [line (in-list (string-split (string-trim str "\n") "\n"))])
(color-display (format (if (zero? i) "~a~a" "\n~a~a") erase-line line)))
(color-display str))]
[_ (map (lambda (item) (helper item (or bg prev-bg) (or fg prev-fg)))
children)])
(when prev-bg (background-color prev-bg))
(when prev-fg (foreground-color prev-fg)))
(num-newlines #f)
(helper ast))
(command-line
#:program "get-challenge"
#:args (day)
(define in (aoc-fetch-challenge (getenv "AOC_YEAR") day (getenv "AOC_SESSION")))
(use-html-spec #f)
(define doc-xmls (read-html-as-xml in))
(close-input-port in)
(define doc `(top-element ,@(map xml->xexpr doc-xmls)))
(define main (find-element 'main doc))
(define ast (xexpr->style-ast main))
; (pretty-write ast)
(output-style-ast ast))

15
bin/get-input

@ -0,0 +1,15 @@
#!/usr/bin/env racket
#lang racket
(require "../lib/aoc.rkt")
(command-line
#:program "get-input"
#:args (day)
(define in (aoc-fetch-input (getenv "AOC_YEAR") day (getenv "AOC_SESSION")))
(define out (build-path (current-directory)
"data"
(string-append "day" day ".txt")))
(cond [(file-exists? out) (displayln "input data already exists")]
[else
(call-with-output-file out (lambda (prt) (copy-port in prt)))
(displayln "done!")]))

15
day1.rkt

@ -0,0 +1,15 @@
#lang racket
(require "lib/common.rkt")
(define (day1a lst)
(void))
(define (day1b lst)
(void))
(module+ main
(call-with-input-file "data/day1.txt"
(lambda (prt)
(define lines (port->lines prt))
(answer 1 1 (day1a lines))
(answer 1 2 (day1b lines)))))

119
lib/aoc.rkt

@ -0,0 +1,119 @@
#lang racket
(require net/uri-codec net/http-client)
(provide aoc-fetch-input
aoc-fetch-challenge
aoc-submit-answer
aoc-complete?
aoc-set-complete!)
; stolen from:
; https://git.lain.faith/haskal/aoc2020/src/branch/aoc2020/scripts/aoc-lib.rkt
(define *host* "adventofcode.com")
(define *status-file* ".status.rktd")
; generate API path
(define/contract (puzzle-path year day endpoint)
(-> string? string? (or/c "input" "answer" false/c) path?)
(define base (build-path "/" year "day" day))
(if endpoint (build-path base endpoint) base))
; sets necessary headers for API
(define (make-headers session)
(list (string-append "Cookie: session=" session)
"Content-Type: application/x-www-form-urlencoded"))
; http request helper
(define (aoc-request year day endpoint session
[method 'GET] [data #f])
(define (parse-headers hlist)
(for/list ([h (in-list hlist)])
(match h
[(pregexp #px"^([^:]+): (.*?)$" (list _ k v))
(cons (string->symbol (string-downcase (bytes->string/utf-8 k)))
(bytes->string/utf-8 v))]
[x (cons 'unknown x)])))
(define (do-request path headers method data)
(define-values (status headers-out content)
(http-sendrecv *host* path
#:ssl? #t
#:headers headers
#:method method
#:data data))
(define headers-out/parsed (parse-headers headers-out))
(match status
[(pregexp #px"^HTTP/1\\.[10] 200") content]
[(pregexp #px"^HTTP/1\\.[10] 302")
(define location (rest (or (assoc 'location headers-out/parsed)
(error "got 302 with no location"))))
(printf "got redirect to ~a\n" location)
(close-input-port content)
(do-request location headers 'GET #f)]
[(pregexp #px"^HTTP/1\\.[10] 404")
(error "endpoint returned 404.\n response: " (port->bytes content))]
[stat
(error "endpoint returned unexpected data.\n status: "
stat
"\n response: "
(port->bytes content))]))
(do-request (path->string (puzzle-path year day endpoint))
(make-headers session)
method data))
; gets the input file for a challenge
(define/contract (aoc-fetch-input year day session)
(-> string? string? string? input-port?)
(aoc-request year day "input" session))
; submits an answer to the server
(define/contract (aoc-submit-answer year day session part answer)
(-> string? string? string? (or/c 1 2 "1" "2") string? (or/c symbol? bytes?))
(define data `((level . ,(~a part))
(answer . ,answer)))
(define resp
(port->bytes (aoc-request year day "answer" session 'POST
(alist->form-urlencoded data))))
(match resp
[(pregexp #px"That's the right answer")
(aoc-set-complete! day part)
'answer-correct]
[(pregexp #px"That's not the right answer")
'answer-incorrect]
[(pregexp #px"You gave an answer too recently")
'rate-limited]
[(pregexp #px"Did you already complete it?")
(aoc-set-complete! day part)
'already-completed]
[x x]))
; fetches the HTML page for a challenge
(define/contract (aoc-fetch-challenge year day session)
(-> string? string? string? input-port?)
(aoc-request year day #f session))
; generates entries for the challenge status file
(define (day+part->key day part)
(when (string? day)
(set! day (string->number day)))
(when (string? part)
(set! part (string->number part)))
(cons day part))
; gets the status file
(define (aoc-get-status)
(cond [(file-exists? *status-file*)
(call-with-input-file *status-file* read)]
[else '()]))
; is a challenge complete already?
(define (aoc-complete? day part)
(set-member? (aoc-get-status) (day+part->key day part)))
; marks a challenge as completed
(define (aoc-set-complete! day part)
(define status (set-add (aoc-get-status) (day+part->key day part)))
(call-with-output-file *status-file*
(lambda (prt)
(write status prt))
#:mode 'binary
#:exists 'replace))

103
lib/common.rkt

@ -0,0 +1,103 @@
#lang racket
(require "aoc.rkt"
parser-tools/lex
syntax/parse/define
threading
(for-syntax syntax/for-body))
(provide (all-from-out threading)
dbg vector-reverse
values->list list->values
blank? datum? format-datum
for/min for/max
lex-string
answer)
(define (dbg a)
(pretty-print a)
a)
(define (vector-reverse v)
(list->vector (reverse (vector->list v))))
(define-simple-macro (values->list body:expr ...+)
(call-with-values (lambda () body ...) list))
(define (list->values lst)
(apply values lst))
(define (blank? str)
(for/and ([c (in-string str)])
(char-blank? c)))
(define (datum? x)
(or (list? x) (symbol? x)))
(define (string->datum str)
(unless (blank? str)
(define result (read (open-input-string (format "(~a)" str))))
(if (= (length result) 1)
(car result)
result)))
(define (format-datum datum-template . args)
(unless (datum? datum-template)
(raise-argument-error 'format-datums "datum?" datum-template))
(string->datum (apply format (format "~a" datum-template)
(map (lambda (arg)
(if (syntax? arg)
(syntax->datum arg)
arg))
args))))
(define-syntax (for/max stx)
(syntax-case stx ()
[(_ clauses body ... tail-expr)
(with-syntax ([original stx]
[((pre-body ...) (post-body ...))
(split-for-body stx #'(body ... tail-expr))])
#'(for/fold/derived original
([current-max -inf.0])
clauses
pre-body ...
(define maybe-new-max (let () post-body ...))
(if (> maybe-new-max current-max)
maybe-new-max
current-max)))]))
(define-syntax (for/min stx)
(syntax-case stx ()
[(_ clauses body ... tail-expr)
(with-syntax ([original stx]
[((pre-body ...) (post-body ...))
(split-for-body stx #'(body ... tail-expr))])
#'(for/fold/derived original
([current-min +inf.0])
clauses
pre-body ...
(define maybe-new-min (let () post-body ...))
(if (< maybe-new-min current-min)
maybe-new-min
current-min)))]))
(define (lex-string lexer str)
(define in (open-input-string str))
(port-count-lines! in)
(let loop ([v (lexer in)])
(cond [(void? (position-token-token v)) (loop (lexer in))]
[(eof-object? (position-token-token v)) '()]
[else (cons v (loop (lexer in)))])))
(define (answer day part answer)
(printf "answer ~a.~a: ~s\n" day part answer)
(unless (aoc-complete? day part)
(printf "submit? [Y/n]: ")
(match (string-downcase (string-trim (read-line)))
[(or "" "y" "yes")
(printf "glhf\n")
(define resp
(aoc-submit-answer (getenv "AOC_YEAR")
(~a day)
(getenv "AOC_SESSION")
(~a part)
(~a answer)))
(printf "server responded: ~a\n" resp)]
[_ (printf "coward\n")])))

15
tmpl.rkt

@ -0,0 +1,15 @@
#lang racket
(require "lib/common.rkt")
(define (dayNa lst)
(void))
(define (dayNb lst)
(void))
(module+ main
(call-with-input-file "data/dayN.txt"
(lambda (prt)
(define lines (port->lines prt))
(answer N 1 (dayNa lines))
(answer N 2 (dayNb lines)))))
Loading…
Cancel
Save