#!/usr/bin/guile
!#

(import (term ansi-color) (sph filesystem) (sph hashtable) (sph io) (sph list) (sph number) (sph other) (sph process) (sph string) (sph vector) (sph) (ice-9 ftw) (sph cli))
(define prog-arg ((cli-create #:option (q ((all #:names #\a) (clear #:cames #\c))))))
(define colors (list->vector (map any->list (q (none WHITE BLUE MAGENTA GREEN)))))
(define color-count (vector-length colors))
(define color-size-min (- (current-time) (* 86400 15)))
(define color-size-max (current-time))
(define disable-max-list-count (alist-ref prog-arg (q all) #f))
(define max-list-count 30)

(define (size->color a range-min range-max)
  (let
    (index
      (max 0
        (inexact->exact (round (* (- a range-min) (/ (- color-count 1) (- range-max range-min)))))))
    (vector-ref colors index)))

(define (head a count) (if (> (length a) count) (take a count) a))
(define get-sort-property stat:size)

(define (find-file-name-proc path)
  (l (a)
    (let*
      ( (stat-info (stat (string-append path "/" a)))
        (color (size->color (get-sort-property stat-info) color-size-min color-size-max)))
      (pair (get-sort-property stat-info)
        (apply colorize-string
          (append
            (if (eqv? (q directory) (stat:type stat-info)) (pairs a (q UNDERLINE) color)
              (pair a color))))))))

(define (find-match-proc names)
  (if (null? names) (l (e) (not (dotfile? e)))
    (l (e) (and (not (dotfile? e)) (every (l (name) (string-contains e name)) names)))))

(define (find path names)
  (map (find-file-name-proc path) (scandir path (find-match-proc names) (l as #t))))

(define-syntax-rule (replace-dot a)
  (string-replace-char (string-replace-char a #\space #\-) #\. #\space))

(define (lf names)
  (each (l (e) (display (replace-dot (tail e))) (newline))
    (let (file-names (sort (find (getcwd) names) (l (a b) (> (first a) (first b)))))
      (if disable-max-list-count file-names (head file-names max-list-count)))))

(if (alist-ref prog-arg (q clear) #t) (begin (display #\esc) (display "c")))
(lf (map string-downcase (alist-ref prog-arg (q ()) (q ()))))