fork download 
  1. #!/usr/bin/env racket
  2. #lang racket
  3.  
  4. (require srfi/1 srfi/11 srfi/13 srfi/41 srfi/48)
  5.  
  6. (define *calender-base*
  7.   (stream-map (lambda (year)
  8.                 `(31 ,(if (or (zero? (modulo year 400))
  9.                              (and (zero? (modulo year 4))
  10.                                  (not (zero? (modulo year 100)))))
  11.                          29
  12.                          28)
  13.                     31 30 31 30 31 31 30 31 30 31))
  14.              (stream-from 0)))
  15.  
  16. (define (make-calender year month)
  17.   (let loop ((blanks (modulo
  18.                       (fold +
  19.                            (stream-fold + 0
  20.                                        (stream-map
  21.                                         (lambda (y)
  22.                                           (apply + y))
  23.                                         (stream-cdr
  24.                                          (stream-take year *calender-base*))))
  25.                            (take (stream-ref *calender-base* year) (- month 1)))
  26.                       7))
  27.              (count 0)
  28.              (days (iota (list-ref
  29.                           (stream-ref *calender-base* year)
  30.                           (- month 1)) 1))
  31.              (ls '()))
  32.     (cond ((null? days) (apply string-append (reverse ls)))
  33.          ((= count 7) (loop blanks
  34.                            0
  35.                            days
  36.                            (cons "~%" ls)))
  37.          ((zero? blanks) (loop blanks
  38.                               (+ count 1)
  39.                               (cdr days)
  40.                               (cons (string-pad
  41.                                      (number->string (car days))
  42.                                      3) ls)))
  43.          (else (loop (- blanks 1)
  44.                     (+ count 1)
  45.                     days
  46.                     (cons "   " ls))))))
  47.  
  48. (define *msg* '("西暦年を入力して下さい "
  49.                 "月を入力して下さい "
  50.                 "~%~%~t~d年~2F月~%"))
  51.  
  52. (define (main)
  53.   (let loop ((msg *msg*) (env '()))
  54.     (cond ((null? msg)
  55.            (format #t (make-calender (cadr env) (car env))))
  56.          ((= (length msg) 1)
  57.           (format #t (car msg) (cadr env) (car env))
  58.           (loop (cdr msg) env))
  59.          (else (format #t (car msg))
  60.               (loop (cdr msg) (cons (read) env))))))
  61.  
  62. (main)
Success #stdin #stdout 0.57s 91668KB
comments (?)
stdin 
Standard input is empty
stdout 
Standard output is empty
https://ideone.com/L9taWl
language:
Racket (racket 7.0)
created:
4 years ago
visibility:
secret

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!