crossfire/crossfire/main.rkt

#lang racket/base

(require racket/bool racket/function racket/match racket/runtime-path racket/set racket/vector
         (rename-in scribble/text/output [output scribble-output])
         scribble/text
         (for-syntax racket/base racket/syntax))

(module+ test
  (require rackunit))

(module+ test
  (check-equal? (+ 2 2) 4))

(module+ main
  (require racket/cmdline)
  (define who (box "world"))
  (command-line
    #:program "my-program"
    #:once-each
    [("-n" "--name") name "Who to say hello to" (set-box! who name)]
    #:args ()
    (void)))


;; templating infrastructure

(define (eval-template file vars [port (current-output-port)])
  (define cs (current-namespace))
  (define output-exp
    (parameterize ([current-namespace (make-base-namespace)])
      (namespace-attach-module cs 'scribble/text)
      (namespace-require 'scribble/text)
      (hash-for-each vars namespace-set-variable-value!)
      (eval `(include/text ,file))))
  (scribble-output output-exp port))


;; manifest.rkt processing

(define (make-iset) '())

(define (iset-add iset start end)
  (when (> start end)
    (error "invalid interval" start end))

  (define (iset-merge iset)
    (define (iset-merge-helper iset acc)
      (match iset
        ['() (reverse acc)]
        [(cons (cons fs fe) r)
         (match-define (cons (cons afs afe) ar) acc)
         (if (<= fs afe)
           (iset-merge-helper r (cons (cons afs (max fe afe)) ar))
           (iset-merge-helper r (cons (cons fs fe) acc)))]))

    (if (empty? iset)
      iset
      (iset-merge-helper (rest iset) (list (first iset)))))

  (define (iset-insert iset start end)
    (match iset
      ['() (list (cons start end))]
      [(cons (cons fs fe) r)
       (if (>= fs start)
         (cons (cons start end) iset)
         (cons (cons fs fe) (iset-insert r start end)))]))

  (iset-merge (iset-insert iset start end)))

(define (char->iset ch)
  (define cp (char->integer ch))
  (iset-add (make-iset) cp (add1 cp)))

(define (string->iset str)
  (for/fold ([iset (make-iset)]) ([ch (in-string str)])
    (define cp (char->integer ch))
    (iset-add iset cp (add1 cp))))

(define (range->iset a b)
  (iset-add (make-iset) a b))

(define builtin-isets
  (hash "?l" (string->iset "abcdefghijklmnopqrstuvwxyz")
        "?u" (string->iset "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
        "?d" (string->iset "0123456789")
        "?s" (string->iset " !\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~")
        "?a" (range->iset 32 127)
        "?b" (range->iset 0 256)))

(define (parse-manifest manifest-def)
  (struct manifest [name mode command isets pattern] #:transparent)

  (define (eq/m x) (curry equal? x))

  (define-syntax (check-false stx)
    (syntax-case stx ()
      [(_ what)
       (with-syntax ([id (format-id stx "manifest-~a" #'what)]
                     [idsym #''what])
         #'(when (false? (id mf))
             (error "manifest attribute missing:" idsym)))]))

  (define mf
    (for/fold ([mf (manifest #f 'stdin #f builtin-isets #f)])
              ([line (in-list manifest-def)])
      (match line
        [(list (? (eq/m 'name)) name) (struct-copy manifest mf [name name])]
        [(list (? (eq/m 'mode)) mode) (struct-copy manifest mf [mode mode])]
        [(list (? (eq/m 'command)) command) (struct-copy manifest mf [command command])]
        [(list (? (eq/m 'iset)) name val)
         (struct-copy manifest mf
                      [isets (hash-set (manifest-isets mf)
                                         (symbol->string name) (string->iset val))])]
        [(list (? (eq/m 'pattern)) pattern) (struct-copy manifest mf [pattern pattern])])))

  (check-false name)
  (check-false command)
  (check-false pattern)

  (define isets (manifest-isets mf))
  (define pattern
    (for/vector ([x (in-list (regexp-match* #rx"\\??." (manifest-pattern mf)))])
      (if (= 1 (string-length x))
        (char->iset (string-ref x 0))
        (hash-ref isets x (lambda () (error "no such iset defined" x))))))
  (values (manifest-name mf) (manifest-mode mf) (manifest-command mf) pattern))


;; pattern processing

(define (iset-count iset)
  (for/sum ([ival (in-list iset)])
    (- (cdr ival) (car ival))))

(define (pattern-count pattern)
  (for/fold ([sum 1]) ([p (in-vector pattern)])
    (* sum (iset-count p))))

;; design recipe violations follow
;; (sorry)
;; (i wanted this to be fast so i try to avoid spamming the heap)
(define (pattern-generate pattern out-port)
  (define len (vector-length pattern))
  (define gen (make-bytes len))
  (define (output gen)
    (write-bytes gen out-port)
    (printf "\n"))
  (define (permute i gen)
    (cond [(= i len) (output gen)]
          [else
            (for ([chr (in-set (vector-ref pattern i))])
              (bytes-set! gen i chr)
              (permute (add1 i) gen))]))
  (permute 0 gen))

;; ok gamer move time
(define-runtime-path codegen-template "codegen.template")
(define (pattern-codegen pattern)
  (eval-template `(file ,(path->string codegen-template)) (hash 'pattern pattern)))

(define-values [name mode command pattern]
  (parse-manifest
    '((name "test")
      (mode stdin)
      (command ("meme"))
      (pattern "test?d?a?a?s"))))

; (pattern-generate pattern (current-output-port))
; (displayln (pattern-count pattern))
(pattern-codegen pattern)