haskal
/
aoc2020
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

implement new scripts goodies

This commit is contained in:
xenia 2020-12-02 03:02:58 -05:00
parent ac90336f64
commit d3988a432d
4 changed files with 341 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

228
scripts/ansi-color.rkt Normal file
View File

@ -0,0 +1,228 @@
#lang racket/base
;; original source: https://github.com/renatoathaydes/ansi-color
;; modified to provide font-style because i need that bold
(require racket/match)
(provide color-display
color-displayln
ansi-color?
with-colors
background-color
foreground-color
font-style
erase-line)
;; Color and decoration escape definitions
(define reset "\033[0m")
(define erase-line "\033[K")
(define (bkg-color256 code)
(string-append "\033[48;5;" (number->string code) "m"))
(define (fore-color256 code)
(string-append "\033[38;5;" (number->string code) "m"))
(define decoration-map
#hasheq(
(underline . "\033[4m")
(bold . "\033[1m")
(reversed . "\033[7m")))
(define fore-color-map
#hasheq(
(black . "\033[30m")
(red . "\033[31m")
(green . "\033[32m")
(yellow . "\033[33m")
(blue . "\033[34m")
(magenta . "\033[35m")
(cyan . "\033[36m")
(white . "\033[37m")
(b-black . "\033[30;1m")
(b-red . "\033[31;1m")
(b-green . "\033[32;1m")
(b-yellow . "\033[33;1m")
(b-blue . "\033[34;1m")
(b-magenta . "\033[35;1m")
(b-cyan . "\033[36;1m")
(b-white . "\033[37;1m")))
(define bkg-color-map
#hasheq(
(black . "\033[40m")
(red . "\033[41m")
(green . "\033[42m")
(yellow . "\033[43m")
(blue . "\033[44m")
(magenta . "\033[45m")
(cyan . "\033[46m")
(white . "\033[47m")
(b-black . "\033[40;1m")
(b-red . "\033[41;1m")
(b-green . "\033[42;1m")
(b-yellow . "\033[43;1m")
(b-blue . "\033[44;1m")
(b-magenta . "\033[45;1m")
(b-cyan . "\033[46;1m")
(b-white . "\033[47;1m")))
;; customization parameters
(define background-color (make-parameter ""
(lambda (arg) (as-escape-seq #t arg))))
(define foreground-color (make-parameter ""
(lambda (arg) (as-escape-seq #f arg))))
(define font-style (make-parameter ""
(lambda (arg) (as-style-seq arg))))
(define no-reset (make-parameter #f))
;; implementation
(define (ansi-color? x)
(or
(and (integer? x) (<= x 255) (>= x 0))
(and (symbol? x) (hash-has-key? fore-color-map x))))
(define (as-escape-seq bkg? arg)
(define (raise-arg-error)
(raise-arguments-error 'color
"Cannot convert argument to color (not a valid symbol or integer in the 0-255 range)"
"color"
arg))
(define map (if bkg? bkg-color-map fore-color-map))
(match arg
[(? null?) ""]
["" ""]
[(? symbol? s) (hash-ref map s (lambda () (raise-arg-error)))]
[(? integer? x)
#:when (and (<= x 255) (>= x 0))
((if bkg? bkg-color256 fore-color256) x)]
[_ (raise-arg-error)]))
(define (as-style-seq arg)
(define (raise-arg-error)
(raise-arguments-error 'style
"Cannot convert argument to style (not a valid symbol)"
"style"
arg))
(match arg
["" ""]
[(? null?) ""]
[(? symbol? s) (hash-ref decoration-map s (lambda () (raise-arg-error)))]
[_ (raise-arg-error)]))
(define (needs-reset? bkg fore style)
(cond [(no-reset) #f]
[else (not (and (equal? "" bkg)
(equal? "" fore)
(equal? "" style)))]))
(define (color-display datum [out (current-output-port)])
(let* ([bkg (background-color)]
[fore (foreground-color)]
[style (font-style)]
[-reset (if (needs-reset? bkg fore style) reset "")])
(display (string-append bkg fore style datum -reset) out)))
(define (color-displayln datum [out (current-output-port)])
(color-display datum out)
(newline out))
(define with-colors
(case-lambda
[(bkg-color fore-color proc)
(parameterize ([background-color bkg-color]
[foreground-color fore-color]
[no-reset #t])
(color-display "") ; sets the colors in the terminal
(proc)
(display reset))] ; reset colors in the terminal
[(fore-color proc)
(with-colors null fore-color proc)]))
;; TESTS
(module+ test
(require rackunit)
(check-eq? (needs-reset? "" "" "") #f)
(check-eq? (needs-reset? "red" "" "") #t)
(check-eq? (needs-reset? "" "blue" "") #t)
(check-eq? (needs-reset? "red" "green" "") #t)
(check-eq? (needs-reset? "red" "green" "underline") #t)
(check-eq? (needs-reset? "" "" "underline") #t)
(check-eq? (parameterize ([no-reset #t])
(needs-reset? "" "" "")) #f)
(check-eq? (parameterize ([no-reset #t])
(needs-reset? "red" "green" "reversed")) #f)
(check-eq? (ansi-color? 'red) #t)
(check-eq? (ansi-color? 'white) #t)
(check-eq? (ansi-color? 'black) #t)
(check-eq? (ansi-color? 'b-red) #t)
(check-eq? (ansi-color? 'b-white) #t)
(check-eq? (ansi-color? 'b-black) #t)
(check-eq? (ansi-color? 'some) #f)
(check-eq? (ansi-color? 'foo-bar) #f)
(check-eq? (ansi-color? 0) #t)
(check-eq? (ansi-color? 1) #t)
(check-eq? (ansi-color? 10) #t)
(check-eq? (ansi-color? 200) #t)
(check-eq? (ansi-color? 255) #t)
(check-eq? (ansi-color? 256) #f)
(check-eq? (ansi-color? -1) #f)
(check-eq? (ansi-color? -10) #f)
(check-eq? (ansi-color? "blue") #f)
(check-eq? (ansi-color? #t) #f)
(define (wrap-in-color color text)
(string-append (hash-ref fore-color-map color) text reset))
(define (get-output proc)
(let ([out (open-output-string)])
(parameterize ([current-output-port out])
(proc)
(get-output-string out))))
; tests for color-display
(let ([hello-uncolored (get-output (lambda () (color-display "hello")))]
[world-fore-red (get-output (lambda ()
(parameterize ([background-color 'red])
(color-display "world"))))]
[tree-fore-blue (get-output (lambda ()
(parameterize ([foreground-color 'blue])
(color-display "tree"))))]
[animal-yellow-black (get-output (lambda ()
(parameterize ([background-color 'yellow]
[foreground-color 'black])
(color-display "animal"))))]
[something-bold (get-output (lambda ()
(parameterize ([font-style 'bold])
(color-display "something"))))])
(check-equal? hello-uncolored "hello")
(check-equal? world-fore-red "\033[41mworld\033[0m")
(check-equal? tree-fore-blue "\033[34mtree\033[0m")
(check-equal? animal-yellow-black "\033[43m\033[30manimal\033[0m")
(check-equal? something-bold "\033[1msomething\033[0m"))
; tests for with-colors
(let ([blue-and-white (get-output (lambda () (with-colors 'blue 'white (lambda () (display "b-a-w")))))]
[red-and-green (get-output (lambda () (with-colors 'red 'green (lambda () (display "r-a-g")))))]
[blue (get-output (lambda () (with-colors 'blue (lambda () (display "b")))))]
[white (get-output (lambda () (with-colors 'white (lambda () (display "w")))))])
(check-equal? blue-and-white "\033[44m\033[37mb-a-w\033[0m")
(check-equal? red-and-green "\033[41m\033[32mr-a-g\033[0m")
(check-equal? blue "\033[34mb\033[0m")
(check-equal? white "\033[37mw\033[0m"))
)

24
scripts/aoc-lib.rkt
View File

@ -1,16 +1,18 @@
#lang racket
(require net/uri-codec net/http-client)
(provide aoc-fetch-input aoc-submit-answer)
(provide aoc-fetch-input aoc-fetch-challenge aoc-submit-answer)
(define *host* "adventofcode.com")
(define/contract (puzzle-path year day endpoint)
(-> string? string? (or/c "input" "answer") path?)
(build-path "/" year "day" 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))
(define (make-headers session)
(list (string-append "Cookie: session=" session)))
(list (string-append "Cookie: session=" session)
"Content-Type: application/x-www-form-urlencoded"))
(define (aoc-request year day endpoint session [method 'GET] [data #f])
(define (parse-headers hlist)
@ -21,9 +23,9 @@
(bytes->string/utf-8 v))]
[x (cons 'unknown x)])))
(define (do-request path headers)
(define (do-request path headers method data)
(define-values [status headers-out content]
(http-sendrecv *host* path #:ssl? #t #:headers headers))
(http-sendrecv *host* path #:ssl? #t #:headers headers #:method method #:data data))
(define headers-out/parsed (parse-headers headers-out))
(match status
@ -33,13 +35,13 @@
(error "got 302 with no location"))))
(printf "got redirect to ~a\n" location)
(close-input-port content)
(do-request location headers)]
(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)))
(do-request (path->string (puzzle-path year day endpoint)) (make-headers session) method data))
(define/contract (aoc-fetch-input year day session)
(-> string? string? string? input-port?)
@ -53,7 +55,11 @@
(port->bytes (aoc-request year day "answer" session 'POST (alist->form-urlencoded data))))
(match resp
[(pregexp #px"Both parts of this puzzle are complete") 'day-complete]
[(pregexp #px"That's the right answer") 'answer-correct]
[(pregexp #px"That's not the right answer") 'answer-incorrect]
[(pregexp #px"Did you already complete it?") 'already-completed]
[x x]))
(define/contract (aoc-fetch-challenge year day session)
(-> string? string? string? input-port?)
(aoc-request year day #f session))

91
scripts/get-challenge Executable file
View File

@ -0,0 +1,91 @@
#!/usr/bin/env racket
#lang racket
(require html xml "ansi-color.rkt" "aoc-lib.rkt")
;; 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 'script _ ...) #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)
(#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 ""] [prev-fs ""])
(match-define (style-ast fg bg fs children) ast)
(when bg (background-color bg))
(when fg (foreground-color fg))
(when fs (font-style fs))
(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) (or fs prev-fs)))
children)])
(when prev-bg (background-color prev-bg))
(when prev-fg (foreground-color prev-fg))
(when prev-fs (font-style prev-fs)))
(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))

7
scripts/template.rktrkt
View File

@ -2,6 +2,13 @@
;; solution for day @day
;; helper functions here
(module+ test
(require rackunit)
;; tests here
(void))
(module+ main
(define input (file->... "inputs/@day"))
;; part 1