initial commit
This commit is contained in:
commit
6e399e6c43
|
|
@ -0,0 +1,5 @@
|
|||
*.zo
|
||||
*.dep
|
||||
compiled/
|
||||
/config.rktd
|
||||
/awoobot
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
.PHONY: all setup
|
||||
|
||||
all:
|
||||
raco exe -o awoobot awoobot.rkt
|
||||
|
||||
setup:
|
||||
cd astro && $(MAKE) setup
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
*.zo
|
||||
*.dep
|
||||
compiled/
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
.PHONY: all setup
|
||||
|
||||
all:
|
||||
raco make *.rkt
|
||||
|
||||
setup:
|
||||
raco pkg install
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
# astro
|
||||
|
||||
sharks
|
||||
|
|
@ -0,0 +1,72 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/date)
|
||||
|
||||
(provide date-values->jd
|
||||
jd->date-values
|
||||
dynamical-delta-t)
|
||||
|
||||
;; meeus, ch 7
|
||||
|
||||
;; counting from 1
|
||||
(define (date-values->jd year month day)
|
||||
(define julian? (or (< year 1582)
|
||||
(and (= year 1582) (< month 10))
|
||||
(and (= year 1582) (= month 10) (<= day 4))))
|
||||
|
||||
;; there's a range of days that doesn't exist due to the julian/gregorian transition
|
||||
(when (and (= year 1582) (= month 10) (or (> day 4) (< day 15)))
|
||||
(error "invalid date provided"))
|
||||
|
||||
(define-values [year* month*]
|
||||
(if (> month 2)
|
||||
(values year month)
|
||||
(values (sub1 year) (+ 12 month))))
|
||||
(define a (quotient year* 100))
|
||||
(define b (if julian? 0 (+ 2 (- a) (quotient a 4))))
|
||||
(+ (floor (* 365.25 (+ year* 4716))) (floor (* 30.6001 (add1 month*)))
|
||||
day b -1524.5))
|
||||
|
||||
;; (values year month day)
|
||||
(define (jd->date-values jd)
|
||||
(define-values [Z F]
|
||||
(let* ([jd+ (+ 0.5 jd)]
|
||||
[jdq (floor jd+)])
|
||||
(values jdq (- jd+ jdq))))
|
||||
(define A (if (< Z 2299161)
|
||||
Z
|
||||
(let ([α (floor (/ (- Z 1867216.25) 36524.25))])
|
||||
(+ Z 1 α (- (floor (/ α 4)))))))
|
||||
(define B (+ A 1524))
|
||||
(define C (floor (/ (- B 122.1) 365.25)))
|
||||
(define D (floor (* C 365.25)))
|
||||
(define E (floor (/ (- B D) 30.6001)))
|
||||
|
||||
(define day (- B D (floor (* 30.6001 E)) (- F)))
|
||||
(define month (if (< E 14) (sub1 E) (- E 13)))
|
||||
(define year (if (> month 2) (- C 4716) (- C 4715)))
|
||||
(values (inexact->exact year) (inexact->exact month) day))
|
||||
|
||||
(define (dynamical-delta-t year)
|
||||
(define t (/ (- year 2000) 100.))
|
||||
(+ 102. (* 102. t) (* 25.4 t t)))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
;; TODO add tests. page 62
|
||||
;; 7.a
|
||||
(check-= (date-values->jd 1957 10 4.81) 2436116.31 0.000001)
|
||||
;; 7.b
|
||||
(check-= (date-values->jd 333 1 27.5) 1842713.0 0.000001)
|
||||
;; 7.c
|
||||
(define-values [y1 m1 d1] (jd->date-values 2436116.31))
|
||||
(check-equal? y1 1957)
|
||||
(check-equal? m1 10)
|
||||
(check-= d1 4.81 0.000001)
|
||||
;; custom
|
||||
(define jd2 (date-values->jd 2020 9 2.2236))
|
||||
(define-values [y2 m2 d2] (jd->date-values jd2))
|
||||
(check-equal? y2 2020)
|
||||
(check-equal? m2 9)
|
||||
(check-= d2 2.2236 0.000001))
|
||||
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
#lang info
|
||||
|
||||
(define version "0.0.1")
|
||||
(define collection "astro")
|
||||
(define deps '("base"))
|
||||
(define test-omit-paths '("info.rkt"))
|
||||
; (define scribblings '(("astro.scrbl"))')
|
||||
|
|
@ -0,0 +1,260 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/math racket/vector racket/match
|
||||
"./calendar.rkt")
|
||||
|
||||
(provide lunar-next-phase)
|
||||
|
||||
;; meeus, ch 47
|
||||
|
||||
(define (lunar-mean-phase+ k T)
|
||||
(+ 2451550.09766
|
||||
(* 29.530588861 k)
|
||||
(* 0.00015437 T T)
|
||||
(- (* 0.000000150 T T T))
|
||||
(* 0.00000000073 T T T T)))
|
||||
|
||||
;; phase must correspond to the decimal part of k
|
||||
;; phase is one of 'new 'first 'full 'last
|
||||
(define (lunar-precise-phase+ k phase)
|
||||
(define T (/ k 1236.85))
|
||||
(define lmm (lunar-mean-phase+ k T))
|
||||
|
||||
;; corrections
|
||||
(define E (- 1 (* 0.002516 T) (* 0.0000074 T T)))
|
||||
(define (d->r val)
|
||||
(degrees->radians val))
|
||||
|
||||
(define M (d->r (+ 2.5534 (* 29.10535670 k)
|
||||
(* -0.0000014 T T)
|
||||
(* -0.00000011 T T T))))
|
||||
(define M* (d->r (+ 201.5643 (* 385.81693528 k)
|
||||
(* 0.0107582 T T)
|
||||
(* 0.00001238 T T T)
|
||||
(* -0.000000058 T T T T))))
|
||||
(define F (d->r (+ 160.7108 (* 390.67050284 k)
|
||||
(* -0.0016118 T T)
|
||||
(* -0.00000227 T T T)
|
||||
(* 0.000000011 T T T T))))
|
||||
(define Ω (d->r (+ 124.7746 (* -1.56375588 k)
|
||||
(* 0.0020672 T T)
|
||||
(* 0.00000215 T T T))))
|
||||
|
||||
(define A
|
||||
(vector-map
|
||||
d->r
|
||||
(vector (+ 299.77 (* 0.107408 k) (* -0.009173 T T))
|
||||
(+ 251.88 (* 0.016321 k))
|
||||
(+ 251.83 (* 26.651886 k))
|
||||
(+ 349.42 (* 36.412478 k))
|
||||
(+ 84.66 (* 18.206239 k))
|
||||
(+ 141.74 (* 53.303771 k))
|
||||
(+ 207.14 (* 2.453732 k))
|
||||
(+ 154.84 (* 7.306860 k))
|
||||
(+ 34.52 (* 27.261239 k))
|
||||
(+ 207.19 (* 0.121824 k))
|
||||
(+ 291.34 (* 1.844379 k))
|
||||
(+ 161.72 (* 24.198154 k))
|
||||
(+ 239.56 (* 25.513099 k))
|
||||
(+ 331.55 (* 3.592518 k)))))
|
||||
|
||||
(define periodic-multipliers
|
||||
(match phase
|
||||
['new
|
||||
(vector -0.40720
|
||||
(* +0.17241 E)
|
||||
+0.01608
|
||||
+0.01039
|
||||
(* +0.00739 E)
|
||||
(* -0.00514 E)
|
||||
(* +0.00208 E E)
|
||||
-0.00111
|
||||
-0.00057
|
||||
(* +0.00056 E)
|
||||
-0.00042
|
||||
(* +0.00042 E)
|
||||
(* +0.00038 E)
|
||||
(* -0.00024 E)
|
||||
-0.00017
|
||||
-0.00007
|
||||
+0.00004
|
||||
+0.00004
|
||||
+0.00003
|
||||
+0.00003
|
||||
-0.00003
|
||||
+0.00003
|
||||
-0.00002
|
||||
-0.00002
|
||||
+0.00002)]
|
||||
['full
|
||||
(vector -0.40614
|
||||
(* +0.17302 E)
|
||||
+0.01614
|
||||
+0.01043
|
||||
(* +0.00734 E)
|
||||
(* -0.00515 E)
|
||||
(* +0.00209 E E)
|
||||
-0.00111
|
||||
-0.00057
|
||||
(* +0.00056 E)
|
||||
-0.00042
|
||||
(* +0.00042 E)
|
||||
(* +0.00038 E)
|
||||
(* -0.00024 E)
|
||||
-0.00017
|
||||
-0.00007
|
||||
+0.00004
|
||||
+0.00004
|
||||
+0.00003
|
||||
+0.00003
|
||||
-0.00003
|
||||
+0.00003
|
||||
-0.00002
|
||||
-0.00002
|
||||
+0.00002)]
|
||||
[(or 'first 'last)
|
||||
(vector -0.62801
|
||||
(* +0.17172 E)
|
||||
(* -0.01182 E)
|
||||
+0.00862
|
||||
+0.00804
|
||||
(* +0.00454 E)
|
||||
(* +0.00204 E E)
|
||||
-0.00180
|
||||
-0.00070
|
||||
-0.00040
|
||||
(* -0.00034 E)
|
||||
(* +0.00032 E)
|
||||
(* +0.00032 E)
|
||||
(* -0.00028 E E)
|
||||
(* +0.00027 E)
|
||||
-0.00017
|
||||
-0.00005
|
||||
+0.00004
|
||||
-0.00004
|
||||
+0.00004
|
||||
+0.00004
|
||||
+0.00004
|
||||
+0.00002
|
||||
+0.00002
|
||||
-0.00002)]))
|
||||
(define periodic-sine-terms
|
||||
(match phase
|
||||
[(or 'new 'full)
|
||||
(vector M*
|
||||
M
|
||||
(* M* 2)
|
||||
(* F 2)
|
||||
(- M* M)
|
||||
(+ M* M)
|
||||
(* M 2)
|
||||
(- M* (* 2 F))
|
||||
(+ M* (* 2 F))
|
||||
(+ (* 2 M*) M)
|
||||
(* 3 M*)
|
||||
(+ M (* 2 F))
|
||||
(- M (* 2 F))
|
||||
(- (* 2 M*) M)
|
||||
Ω
|
||||
(+ M* (* 2 M))
|
||||
(- (* 2 M*) (* 2 F))
|
||||
(* 3 M)
|
||||
(+ M* M (* -2 F))
|
||||
(+ (* 2 M*) (* 2 F))
|
||||
(+ M* M (* 2 F))
|
||||
(+ M* (- M) (* 2 F))
|
||||
(- M* M (* 2 F))
|
||||
(+ (* 3 M*) M)
|
||||
(* 4 M*))]
|
||||
[(or 'first 'last)
|
||||
(vector M*
|
||||
M
|
||||
(+ M* M)
|
||||
(* 2 M*)
|
||||
(* 2 F)
|
||||
(- M* M)
|
||||
(* 2 M)
|
||||
(- M* (* 2 F))
|
||||
(+ M* (* 2 F))
|
||||
(* 3 M*)
|
||||
(- (* 2 M*) M)
|
||||
(+ M (* 2 F))
|
||||
(- M (* 2 F))
|
||||
(+ M* (* 2 M))
|
||||
(+ (* 2 M*) M)
|
||||
Ω
|
||||
(- M* M (* 2 F))
|
||||
(+ (* 2 M*) (* 2 F))
|
||||
(+ M* M (* 2 F))
|
||||
(- M* (* 2 M))
|
||||
(+ M* M (* -2 F))
|
||||
(* 3 M)
|
||||
(- (* 2 M*) (* 2 F))
|
||||
(+ M* (- M) (* 2 F))
|
||||
(+ (* 3 M*) M))]))
|
||||
|
||||
(define periodic-correction
|
||||
(for/sum ([multiplier (in-vector periodic-multipliers)]
|
||||
[sine-term (in-vector periodic-sine-terms)])
|
||||
(* multiplier (sin sine-term))))
|
||||
|
||||
(define W (+ 0.00306
|
||||
(* -0.00038 E (cos M))
|
||||
(* 0.00026 (cos M*))
|
||||
(* -0.00002 (cos (- M* M)))
|
||||
(* 0.00002 (cos (+ M* M)))
|
||||
(* 0.00002 (cos (* 2 F)))))
|
||||
(define phase-correction
|
||||
(match phase
|
||||
['first W]
|
||||
['last (- W)]
|
||||
[(or 'new 'full) 0]))
|
||||
|
||||
(define additional-multipliers
|
||||
(vector 0.000325
|
||||
0.000165
|
||||
0.000164
|
||||
0.000126
|
||||
0.000110
|
||||
0.000062
|
||||
0.000060
|
||||
0.000056
|
||||
0.000047
|
||||
0.000042
|
||||
0.000040
|
||||
0.000037
|
||||
0.000035
|
||||
0.000023))
|
||||
(define additional-correction
|
||||
(for/sum ([Ai (in-vector A)]
|
||||
[multipler (in-vector additional-multipliers)])
|
||||
(* multipler (sin Ai))))
|
||||
|
||||
; (define r->d radians->degrees)
|
||||
; (printf "lmm ~a E ~a M ~a M* ~a F ~a Ω ~a\n" lmm E (r->d M) (r->d M*) (r->d F) (r->d Ω))
|
||||
; (printf "C1 ~a C2 ~a C3 ~a\n" periodic-correction phase-correction additional-correction)
|
||||
|
||||
(+ lmm periodic-correction phase-correction additional-correction))
|
||||
|
||||
;; 1-indexed again
|
||||
(define (lunar-next-phase jd phase)
|
||||
(define fraction
|
||||
(match phase
|
||||
['new 0.00]
|
||||
['first 0.25]
|
||||
['full 0.50]
|
||||
['last 0.75]))
|
||||
|
||||
(define seekb -3)
|
||||
(define seekf 10)
|
||||
|
||||
(define-values [year month day] (jd->date-values jd))
|
||||
(define k~ (let ([k~ (* (- (+ year (/ (sub1 month) 12)) 2000) 12.3685)])
|
||||
(+ (floor k~) seekb fraction)))
|
||||
|
||||
(define trials (for/vector #:length 10 ([offset (in-range seekb seekf)])
|
||||
(lunar-precise-phase+ (+ k~ offset) phase)))
|
||||
|
||||
(for/first ([x (in-vector trials)]
|
||||
#:when (>= x jd))
|
||||
x))
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
#lang racket/base
|
||||
|
||||
;; empty for now
|
||||
|
|
@ -0,0 +1,75 @@
|
|||
#!/usr/bin/env racket
|
||||
|
||||
#lang racket
|
||||
|
||||
(require astro/calendar astro/lunar
|
||||
racket/date
|
||||
"fedibot.rkt")
|
||||
|
||||
(define (current-date/utc)
|
||||
(seconds->date (* 0.001 (current-inexact-milliseconds)) #f))
|
||||
|
||||
(define (date->jd dt)
|
||||
(match-define (date ss mm hh d m y _ _ _ _) dt)
|
||||
(define d+ (+ d (/ hh 24) (/ mm 1440) (/ ss 86400)))
|
||||
(date-values->jd y m d+))
|
||||
|
||||
(define (jd->date-values* jd)
|
||||
(define-values [y m d] (jd->date-values jd))
|
||||
(define dq (floor d))
|
||||
(define df (- d dq))
|
||||
(define h (* df 24))
|
||||
(define hq (floor h))
|
||||
(define hf (- h hq))
|
||||
(define mm (* hf 60))
|
||||
(define mmq (floor mm))
|
||||
(define mmf (- mm mmq))
|
||||
(define ssq (floor (* mmf 60)))
|
||||
(values y m (inexact->exact dq) (inexact->exact hq) (inexact->exact mmq) (inexact->exact ssq)))
|
||||
|
||||
(define (do-awoo)
|
||||
(define (str-rpt-random str)
|
||||
(apply string-append (vector->list (make-vector (random 1 10) str))))
|
||||
|
||||
(define toot (make-toot (string-append "AWOO" (str-rpt-random "O") (str-rpt-random "!"))))
|
||||
(send-toot/retry-on-err toot)
|
||||
(void))
|
||||
|
||||
(define (run-bot)
|
||||
(define now (current-date/utc))
|
||||
(define now-jd (date->jd now))
|
||||
(define DT (dynamical-delta-t (date-year now)))
|
||||
(define fullmoon-jd (- (lunar-next-phase now-jd 'full)
|
||||
(/ DT 86400)))
|
||||
(displayln now-jd)
|
||||
(displayln fullmoon-jd)
|
||||
(define-values [y m d hh mm ss] (jd->date-values* fullmoon-jd))
|
||||
|
||||
(if (< (- fullmoon-jd now-jd) (/ 60 86400))
|
||||
(begin
|
||||
(displayln "preparing to awoo")
|
||||
(sleep (inexact->exact (floor (* 86400 (- fullmoon-jd now-jd)))))
|
||||
(do-awoo)
|
||||
(sleep 5))
|
||||
(displayln "not time to awoo yet")))
|
||||
|
||||
(define (schedule-next)
|
||||
(define now (current-date/utc))
|
||||
(define now-jd (date->jd now))
|
||||
(define DT (dynamical-delta-t (date-year now)))
|
||||
(define fullmoon-jd (- (lunar-next-phase now-jd 'full)
|
||||
(/ DT 86400)))
|
||||
(define-values [y m d hh mm ss] (jd->date-values* (- fullmoon-jd (/ 30 86400))))
|
||||
(printf "schedule wakeup for: ~a ~a ~a ~a ~a ~a\n" y m d hh mm ss)
|
||||
|
||||
(displayln "invoking systemd")
|
||||
(system* "/usr/bin/env" "systemd-run" "--user" "--same-dir"
|
||||
(format "--on-calendar=~a-~a-~a ~a:~a:~a UTC" y m d hh mm ss)
|
||||
(path->string (path->complete-path (find-system-path 'run-file)))))
|
||||
|
||||
|
||||
(parameterize ([current-config (config-from-file "config.rktd")])
|
||||
(run-bot)
|
||||
(schedule-next)
|
||||
|
||||
(void))
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
#hash((instance . "myinstance.cool")
|
||||
(token . "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA")
|
||||
(char-limit . 500))
|
||||
|
|
@ -0,0 +1,121 @@
|
|||
#lang racket
|
||||
|
||||
(require racket/async-channel
|
||||
json
|
||||
net/url
|
||||
net/uri-codec
|
||||
; net/rfc6455
|
||||
uuid)
|
||||
|
||||
(provide [struct-out app-config]
|
||||
config-from-file
|
||||
current-config
|
||||
make-toot
|
||||
send-toot
|
||||
send-toot/retry-on-err
|
||||
verify-creds
|
||||
; stream-user
|
||||
fetch-toot)
|
||||
|
||||
;; Bot configuration
|
||||
(struct app-config [instance token char-limit] #:transparent)
|
||||
|
||||
(define (config-from-file filename)
|
||||
(define conf (with-input-from-file filename read))
|
||||
;; this could be a macro
|
||||
(app-config
|
||||
(hash-ref conf 'instance)
|
||||
(hash-ref conf 'token)
|
||||
(hash-ref conf 'char-limit 500)))
|
||||
|
||||
;; Represents the current masto config
|
||||
(define current-config (make-parameter #f))
|
||||
|
||||
;; Utils
|
||||
(define (make-api-url path #:ws? [ws? #f] #:query [query '()])
|
||||
(url (if ws? "wss" "https")
|
||||
#f (app-config-instance (current-config))
|
||||
#f #t
|
||||
`(,(path/param "api" '())
|
||||
,(path/param "v1" '())
|
||||
,@(map (lambda (x) (path/param x '())) path))
|
||||
query #f))
|
||||
|
||||
(define (make-header k v)
|
||||
(string-append k ": " v))
|
||||
|
||||
(define (get-authorization)
|
||||
(string-append "Bearer " (app-config-token (current-config))))
|
||||
|
||||
(define (guard-config)
|
||||
(unless (app-config? (current-config))
|
||||
(error "current-config is not set up")))
|
||||
|
||||
;; Creates a toot
|
||||
(define (make-toot status #:cw [cw #f] #:reply-to [reply-to #f]
|
||||
#:sensitive [sensitive #f] #:language [lang #f]
|
||||
#:visibility [visibility #f])
|
||||
(for/fold ([out '()])
|
||||
([name '(status in_reply_to_id sensitive spoiler_text language visibility)]
|
||||
[value (list status reply-to sensitive cw lang visibility)])
|
||||
(cond [(false? value) out]
|
||||
[else (cons (cons name value) out)])))
|
||||
|
||||
;; Sends a toot
|
||||
(define (send-toot toot [idem-key (uuid-string)])
|
||||
(guard-config)
|
||||
(define-values (status headers rsp)
|
||||
(http-sendrecv/url (make-api-url '("statuses"))
|
||||
#:method "POST"
|
||||
#:headers (list
|
||||
(make-header "Idempotency-Key" idem-key)
|
||||
(make-header "Authorization" (get-authorization))
|
||||
(make-header "Content-Type" "application/x-www-form-urlencoded"))
|
||||
#:data (alist->form-urlencoded toot)))
|
||||
(string->jsexpr (port->string rsp)))
|
||||
|
||||
(define MAX-TRIES 10)
|
||||
(define SLEEP-CAP 60)
|
||||
|
||||
(define (send-toot/retry-on-err toot [idem-key (uuid-string)] [tries 0])
|
||||
(guard-config)
|
||||
(define (handle-err ex)
|
||||
(displayln "toot failed")
|
||||
(displayln ex)
|
||||
(if (>= tries MAX-TRIES)
|
||||
(raise ex)
|
||||
(begin
|
||||
(sleep (min SLEEP-CAP (* tries 5)))
|
||||
(send-toot/retry-on-err toot idem-key (add1 tries)))))
|
||||
(with-handlers ([exn? handle-err])
|
||||
(send-toot toot idem-key)))
|
||||
|
||||
(define (verify-creds)
|
||||
(guard-config)
|
||||
(define-values (status headers rsp)
|
||||
(http-sendrecv/url (make-api-url '("accounts" "verify_credentials"))
|
||||
#:headers (list (make-header "Authorization" (get-authorization)))))
|
||||
(string->jsexpr (port->string rsp)))
|
||||
|
||||
(define (fetch-toot toot-id)
|
||||
(guard-config)
|
||||
(define-values (status headers rsp)
|
||||
(http-sendrecv/url (make-api-url (list "statuses" toot-id))
|
||||
#:headers (list (make-header "Authorization" (get-authorization)))))
|
||||
(string->jsexpr (port->string rsp)))
|
||||
|
||||
;; Stream incoming toots
|
||||
; (define (stream-user chan)
|
||||
; (define query (list (cons 'access_token (app-config-token (current-config)))
|
||||
; (cons 'stream "user")))
|
||||
; (define ws (ws-connect (make-api-url '("streaming") #:ws? #t #:query query)))
|
||||
; (define (stream-forever chan)
|
||||
; (let ([msg (ws-recv ws)])
|
||||
; (cond [(equal? msg eof) (void)]
|
||||
; [else
|
||||
; (define msg-data (string->jsexpr msg)
|
||||
; (async-channel-put chan (list (hash-ref msg-data 'event)
|
||||
; (hash-ref msg-data 'payload)))
|
||||
; (stream-forever chan)])))
|
||||
; (stream-forever chan)
|
||||
; (ws-close! ws))
|
||||
Loading…
Reference in New Issue