path: root/bs/core.scm

(define-module (bs core)
  #:use-module ((ice-9 format))
  #:use-module ((system vm program))
  #:use-module ((ice-9 rdelim) #:select (read-line))
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-69)
  #:export (fmt printf pr prn
                first ffirst second rest last butlast
                true? false? some? empty?
                -> ->> fn /. curry comp
                repeat for seq turn
                range ..
                inc dec member? contains?
                comment
                ;; obsolete, use (ice-9 session) instead
                ;; get-source* get-source source
                ))

(define (flip f)           (lambda (x y) (f y x)))
(define (curry f a)        (lambda (b) (apply f (cons a (list b)))))
(define pos?
  (curry < 0))

(define neg?
  (curry > 0))

(define (foldr f end lst)
  (if (null? lst)
      end
      (f (car lst) (foldr f end (cdr lst)))))

(define (foldl f acc lst)
  (if (null? lst)
      acc
      (foldl f (f acc (car lst)) (cdr lst))))

(define (sum lst)          (fold + 0 lst))
(define (product lst)      (fold * 1 lst))

(define count length)

(define (pr . a)
  "Print"
  (for-each display a))

(define (prn . a)
  "Print, followed by a newline"
  (apply pr a)
  (newline))

(define (false? x)
  (not (eq? #t x)))

(define (true? x)
  (eq? #t x))

(define (some? a)
  (not (null? a)))

(define (empty? a)
  (equal? a '()))

(define (first coll)
  (car coll))

(define (ffirst coll)
  (first (first coll)))

(define (rest coll)
  "Returns a list of the items after the first."
  (cdr coll))

(define (second coll)
  (first (rest coll)))

(define (last coll)
  "Return the last time in coll, in linear time."
  (if (second coll)
      (last (rest coll))
      (first coll)))

(define (butlast ls)
  "Return everthing execpt the last element in ls."
  (let ((len (length ls)))
    (list-head ls (- len 1))))

;; Ignores body, returns '().
(define-syntax comment
  (syntax-rules ()
    ((_ ...) '())))

(define (some pred coll)
  (or (pred (first coll))
      (some pred (second coll))))

(define comp compose)

(define (not-any? pred coll)
  (comp not some))

(define (printf . args)
  (display (apply format args)))

(define-syntax fmt
  (syntax-rules ()
    ((_ s args ...)
     (format #f s args ...))))

(define-syntax fn
  (syntax-rules ()
    ((_ args body ...)
     (lambda args body ...))))

(define-syntax ->
  (syntax-rules ()
    [(_ a) a]
    [(_ a (b c ...))
     (b a c ...)]
    [(_ a b)
     (-> a (b))]
    [(_ a b c ...)
     (-> (-> a b) c ...)]))

(define-syntax ->>
  (syntax-rules ()
    [(_ a) a]
    [(_ a (b ...))
     (b ... a)]
    [(_ a b)
     (b a)]
    [(_ a b c ...)
     (->> (->> a b) c ...)]))

;; Shen-like lambda
(define-syntax /.
  (syntax-rules ()
    [(/. a b)
     (lambda (a) b)]
    [(/. a ... b)
     (lambda (a ...) b)]
    [(/. a ... (b ...))
     (lambda (a ...) (b ...))]))

;; https://gist.github.com/cky/8500450
;; clojure-like anonymous functions:
;;
;;   (map ##(+ % 5) '(1 2 3)) ;;=> (6 7 8)
;;
(read-hash-extend
 #\#
 (lambda (_ port)
   (define ht (make-hash-table eqv?))
   (define (ht-ref key)
     (hash-table-ref ht key (lambda ()
                              (define sym (gensym))
                              (hash-table-set! ht key sym)
                              sym)))
   (define (hash-key x)
     (case x
       ((% %1) 1)
       ((%2) 2)
       ((%3) 3)
       ((%&) 0)
       ((#{}#) #f)
       (else (and (symbol? x)
                  (symbol-interned? x)
                  (let ((str (symbol->string x)))
                    (and (char=? #\% (string-ref str 0))
                         (char<=? #\1 (string-ref str 1) #\9)
                         (string->number (substring/shared str 1))))))))
   (define (process x)
     (cond ((hash-key x) => ht-ref)
           ((list? x) (map process x))
           (else x)))
   (define body (process (read port)))
   (define max-arg (apply max 0 (hash-table-keys ht)))
   (define lambda-list (list-tabulate max-arg (compose ht-ref 1+)))
   `(lambda (,@lambda-list . ,(hash-table-ref/default ht 0 '()))
      ,body)))

(define (inc a) (+ a 1))
(define (dec a) (- a 1))

(define* (repeat a #:optional (n 10))
  (do ((i 1 (inc i)))
      ((> i n))
    a))

(define-syntax if-let
  (syntax-rules ()
    [(_ (binding value) then else)
     (let ([binding value])
       (if binding then else))]))

(define-syntax when-let
  (syntax-rules ()
    [(_ (binding value) body ...)
     (when binding body ...)]))

(define (range min max step)
  (if (< min max)
      (cons min (range (+ min step) max step))
      '()))

;; range operator from http://www.mattknox.com/code.html
(define (.. l h . s)
  (let* ((step (if (null? s) 1 (car s))))
    (if (> h l)
        (range l h step)
        (reverse (range h l step)))))

(define (! n)
  (define (fact n a)
    (if (< n 2)
        a
        (fact (- n 1) (* a n))))
  (fact n 1))


;; source utils

(define (skip-lines port n)
  (cond
   ((zero? n) port)
   (else (read-line port) (skip-lines port (1- n)))))

;; NOTE: this source-lookup code might be obsolete, see (ice-9 session)

(define (get-source* source pname)
  (let* ([file (source:file source)]
         [filename (any (fn (x)
                            (let ((f (string-append x "/" file)))
                              (if (file-exists? f) f #f)))
                        %load-path)]
         [re (make-regexp (format #f "\\(define (~a|\\(~a.*\\))" pname pname))]
         [read-between (lambda (in start end)
                         (seek in 0 SEEK_SET)
                         (skip-lines in (1- start))
                         (call-with-output-string
                           (lambda (out)
                             (let self ((line (read-line in))
                                        (cur start))
                               (cond
                                [(or (eof-object? line) (> cur end))
                                 (close in)]
                                [else
                                 (format out "~a~%" line)
                                 (self (read-line in) (inc cur))])))))])
    (call-with-input-file filename
      (lambda (in)
        (let self ((line (read-line in)))
          (cond
           [(eof-object? line) #f]
           [(regexp-exec re line)
            (unread-string line in)
            (let*  ((start (port-line in))
                    (end (begin (read in) (port-line in))))
              (read-between in start (inc end)))]
           [else
            (self (read-line in))]))))))

(define (get-source p)
  "Get the source of a procedure as a string."
  (let ((psrc (program-source p 0)))
    (cond
     [(not psrc) (fmt "<~a: compiled C procedure>\n" p)]
     [(not (source:file psrc)) #f]
     [else (get-source* psrc (symbol->string (procedure-name p)))])))

(define (source p)
  "Print the source of a procedure."
  (pr (get-source p)))

(define member? member)

(define (contains? ls x)
  (member? x ls))

(define (turn ls f)
  (map f ls))

(define (seq x)
  (if (list? x)
      x
      (list x)))

;; is this not in srfi-1?
(define (flatten x)
  (cond ((null? x) '())
        ((pair? x) (append (flatten (car x)) (flatten (cdr x))))
        (else (list x))))