stoe/src/utils.lisp

#|
  This file is a part of stoe project.
  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
|#

(in-package :cl-user)
(defpackage stoe.utils
  (:use :cl)
  (:nicknames :utils)
  (:export :it :aif :awhen
           :safe-first :safe-list
           :group
           :restartable
           :progress-step
           :loop-with-progress
           :add-hook :remove-hook :run-hook
           :update-current-time :get-delta-time
           :make-clock :clock-time :clock-delta
           :update-clock :compare-clocks
           :get-command-line-option
           :get-command-line-option-number))
(in-package :stoe.utils)

(declaim (optimize (debug 3) (safety 3) (speed 0)))

(defmacro aif (test then else)
  "Bind the result of evaluating `test' to a variable named `it', as per Paul Graham's On Lisp."
  `(let ((it ,test))
     (if it
         ,then
         ,else)))

(defmacro awhen (test &body body)
  "Bind the result of evaluating `test' to a variable named `it', as per Paul Graham's On Lisp."
  `(let ((it ,test))
     (when it
       ,@body)))

(defun safe-first (x)
  "Return the first element of `x' if it is a list, return `x' otherwise."
  (if (listp x) (first x) x))

(defun safe-list (x)
  "Return `x' if it is a list, return '(x) otherwise."
  (if (listp x) x (list x)))

(defun group (source &optional (n 2))
  "Regroup the list `source' elements by n."
  (when (zerop n)
    (error "zero length"))
  (labels ((rec (source acc)
             (let ((rest (nthcdr n source)))
               (if (consp rest)
                   (rec rest (cons (subseq source 0 n) acc))
                   (nreverse (cons source acc))))))
    (if source (rec source nil) nil)))

(defmacro restartable (unprotected &body body)
  "Provide a Continue restart unless `unprotected' is t."
  `(if ,unprotected
       (progn
         ,@body)
      (restart-case
          (progn
            ,@body)
        (continue () :report "Continue"))))

(defmacro loop-with-progress (msg &body body)
  "Allow a looping process to display feedback."
  `(let ((progress-max-columns 80))
     (symbol-macrolet ((progress-step
                        (progn
                          (when (> progress-index progress-max-columns)
                            (format t "~%")
                            (setf progress-index 0))
                          (format t "."))))
       (format t ,msg)
       (loop for progress-index upfrom ,(length msg)
            ,@body)
       (format t "~%"))))

(defmacro add-hook (hook fun &optional append)
  "Setup `fun' to be called within specified `hook'."
  `(unless (member ,fun ,hook)
     ,(if append
          `(setf ,hook (append ,hook (list ,fun)))
          `(push ,fun ,hook))))

(defmacro remove-hook (hook fun)
  "Remove `fun' from `hook'."
  `(delete ,fun ,hook))

(defun run-hook (hook &rest args)
  "Apply all functions attached to `hook' with specified `args' if any."
  (let (result)
    (mapc (lambda (fun)
            (setf result (apply fun args)))
          hook)
    result))

(defun get-current-time ()
  "Return the current time in seconds and microseconds."
  #+sbcl (sb-ext:get-time-of-day)
  #-sbcl
  (let* ((time (get-internal-real-time))
         (sec (/ time internal-time-units-per-second))
         (usec (* time (/ 1000000 internal-time-units-per-second))))
    (values sec usec)))

(let ((last-time (cons 0 0))
      (current-time (cons 0 0)))

  (defun update-current-time ()
    "Update the cached time in seconds and microseconds."
    (setf (car last-time) (car current-time))
    (setf (cdr last-time) (cdr current-time))
    (multiple-value-bind (sec usec) (get-current-time)
      (setf (car current-time) sec)
      (setf (cdr current-time) usec)))

  (defun get-delta-time ()
    "Return the difference between the last two cached timers."
    (+ (* (- (car current-time) (car last-time)) 1000000)
       (- (cdr current-time) (cdr last-time)))))

(defstruct (clock (:constructor %make-clock))
  (time 0)
  (last-time 0)
  (scale 1.0)
  (paused nil))

(defun make-clock (&optional (time 0) (scale 1.0) (paused nil))
  "Create a new clock instance with specified parameters or using reasonable defaults."
  (%make-clock :time time :last-time time :scale scale :paused paused))

(defun update-clock (clock &optional delta-time)
  "Update clock using `sec' and `usec' values passed as parameter."
  (unless (clock-paused clock)
    (setf (clock-last-time clock) (clock-time clock))
    (incf (clock-time clock) (* (or delta-time (get-delta-time)) (clock-scale clock)))))

(defun clock-delta (clock)
  (- (clock-time clock) (clock-last-time clock)))

(defun compare-clocks (clock1 clock2)
  "Return the difference between `clock1' and `clock2'."
  (- (clock-time clock1) (clock-time clock2)))

(defun error-implementation-unsupported ()
  "Return an error specifying the current lisp implementation is not supported."
  (error "For now, only sbcl is supported."))

(defun get-command-line-option (argv optname &optional default)
  "Return the option designated by `optname' from the command-line `argv'."
  (let ((opt (member optname argv :test #'equal)))
    (or (and (cdr opt) (second opt)) default)))

(defun get-command-line-option-number (argv optname &optional default)
  "Return the option designated by `optname' from the command-line `argv' as a number."
  (let ((opt (get-command-line-option argv optname)))
    (if opt
        (let ((value (with-input-from-string (in opt)
                       (read in))))
          (assert (numberp value))
          value)
        default)))