clone url: git://git.m455.casa/nicethings
src/main.scm
| 1 | (import utf8 |
| 2 | ; (chicken pretty-print) ;; for debugging |
| 3 | srfi-1 |
| 4 | srfi-152 |
| 5 | (chicken format) |
| 6 | (chicken file) |
| 7 | (chicken process-context) |
| 8 | (chicken pathname) |
| 9 | (chicken port) |
| 10 | (chicken io) |
| 11 | (chicken random)) |
| 12 | |
| 13 | (define NICETHINGS-FILE ".nicethings") |
| 14 | |
| 15 | (define (string->lines str) |
| 16 | (with-input-from-string str read-lines)) |
| 17 | |
| 18 | (define (file->string file) |
| 19 | (with-input-from-file file read-string)) |
| 20 | |
| 21 | (define (file->lines file) |
| 22 | (let ((file-contents (file->string file))) |
| 23 | (if (equal? file-contents #!eof) |
| 24 | '() |
| 25 | (string->lines (string-trim-both file-contents))))) |
| 26 | |
| 27 | (define (random-list-ref lst) |
| 28 | (list-ref lst (pseudo-random-integer (length lst)))) |
| 29 | |
| 30 | (define (username-has-nicethings-file? username) |
| 31 | (let ((user-directory (make-pathname "/home" username))) |
| 32 | (if (file-readable? user-directory) |
| 33 | (let ((nicethings-absolute-path (make-pathname user-directory NICETHINGS-FILE))) |
| 34 | (if (and (file-exists? nicethings-absolute-path) |
| 35 | (file-readable? nicethings-absolute-path)) |
| 36 | nicethings-absolute-path |
| 37 | #f)) |
| 38 | #f))) |
| 39 | |
| 40 | (define (paths-to-nicethings-files directory-list) |
| 41 | (if (null? directory-list) |
| 42 | '() |
| 43 | (let ((nicethings-absolute-path (username-has-nicethings-file? (car directory-list)))) |
| 44 | (if nicethings-absolute-path |
| 45 | (cons nicethings-absolute-path (paths-to-nicethings-files (cdr directory-list))) |
| 46 | (paths-to-nicethings-files (cdr directory-list)))))) |
| 47 | |
| 48 | (define (file-not-empty? file) |
| 49 | (let* ((lines (file->lines file)) |
| 50 | (empty-lines-removed (filter (lambda (line) |
| 51 | (> (string-length (string-trim-both line)) 0)) |
| 52 | lines))) |
| 53 | (not (null? empty-lines-removed)))) |
| 54 | |
| 55 | (define (random-nicething) |
| 56 | (let ((nicethings-file-paths (paths-to-nicethings-files (directory "/home")))) |
| 57 | (if (not (null? nicethings-file-paths)) |
| 58 | (let* ((file-paths-empty-nicethings-removed (filter file-not-empty? nicethings-file-paths)) |
| 59 | (random-path (random-list-ref file-paths-empty-nicethings-removed)) |
| 60 | (nicethings-list (file->lines random-path))) |
| 61 | (random-list-ref (if (not (null? nicethings-list)) |
| 62 | nicethings-list |
| 63 | '("blep")))) |
| 64 | "it looks like no one has added anything to their ~/.nicethings file D:"))) |
| 65 | |
| 66 | (define help-message |
| 67 | #<<string-block |
| 68 | description |
| 69 | ========== |
| 70 | |
| 71 | a program for collaboratively cheering each other up. |
| 72 | |
| 73 | usage |
| 74 | ===== |
| 75 | |
| 76 | - run `nicethings` to print a random nicething. |
| 77 | |
| 78 | how it works |
| 79 | ============ |
| 80 | |
| 81 | - people create a .nicethings file in their home directory. |
| 82 | - people add one nice message per line in their .nicethings file |
| 83 | - a random username and then a random line from that person's .nicethings file is chosen. |
| 84 | - people don't need to create their own .nicethings file in their home directory |
| 85 | to use the program. |
| 86 | string-block |
| 87 | ) |
| 88 | |
| 89 | (define (main args) |
| 90 | (if (null? args) |
| 91 | (print (random-nicething)) |
| 92 | (case (string->symbol (car args)) |
| 93 | ((--help -help -h help) |
| 94 | (print help-message)) |
| 95 | (else (print help-message))))) |
| 96 | |
| 97 | (main (command-line-arguments)) |