loise

(defmodule loise-pgm
  (export all))
  ; (export (default-options 0)
  ;         (perlin 1) (perlin 2)
  ;         (simplex 1) (simplex 2)
  ;         (write 3)))

;;; >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
;;; Options
;;; >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

(defun default-options ()
  (++
    `(#(width 256)
      #(height 128)
      #(multiplier 4.0)
      #(random false)
      #(seed 42))
    (loise-const:base-options)))

;;; >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
;;; API
;;; >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

(defun perlin (filename)
  (perlin filename (default-options)))

(defun perlin (filename options)
  (write filename
         (build-pgm #'get-perlin-point/3 options)
         options))

(defun simplex (filename)
  (simplex filename (default-options)))

(defun simplex (filename options)
  (write filename
         (build-pgm #'get-simplex-point/3 options)
         options))

;;; >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
;;; Supporting functions
;;; >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

(defun magic () #"P5")
(defun whitespace () #"\n")
(defun grey-scale-depth () 255)

(defun write (filename data options)
  (file:write_file filename (list (binary ((image-header options) binary))
                                  data)))

(defun build-pgm (func options)
  "Builds the body of a grey-scale Netpbm image with the specified size and
  shape by calling the specified function on the coordinates of each point.

  The passed function takes an x and y coordinate as agument and returns a
  grey-scale value."
  (let* ((new-opts (++ (loise-util:update-perm-table-options options)
                       (default-options)))
         (width (proplists:get_value 'width new-opts))
         (height (proplists:get_value 'height new-opts)))
     (list-comp ((<- x (lists:seq 0 width))
                 (<- y (lists:seq 0 height)))
                (funcall func x y new-opts))))

(defun get-perlin-point (x y options)
  (get-point x y #'loise:get-perlin-point/4 options))

(defun get-simplex-point (x y options)
  (get-point x y #'loise:get-simplex-point/4 options))

(defun get-point (x y func options)
  (let ((value (funcall func
                 `(,x ,y)
                 (loise-util:get-dimensions options)
                 (proplists:get_value 'multiplier options)
                 options)))
    (get-graded-point value options)))

(defun get-graded-point (value options)
  (let ((adjusted (lutil-math:color-scale value #(-1 1))))
    (case (proplists:get_value 'grades options)
      ('undefined
        adjusted)
      (grades
        (lutil-math:get-closest adjusted grades)))))

(defun image-header (options)
  (image-header (proplists:get_value 'width options)
                (proplists:get_value 'height options)))

(defun image-header (width height)
  (binary ((magic) binary)
          ((whitespace) binary)
          ((integer_to_binary width) binary)
          ((whitespace) binary)
          ((integer_to_binary height) binary)
          ((whitespace) binary)
          ((integer_to_binary (grey-scale-depth)) binary)
          ((whitespace) binary)))