diamonds.lisp

;;; Diamond problem
;;; Solutions by Rainer Joswig, [email protected], 2016

;;; See "Diamond Kata"

;   A
;  B B 
; C   C
;  B B 
;   A  

;;; ================================================================
;;; Helper Functions

(defun letter-value (letter)
  "the numeric value of a letter a-z or A-Z"
  (- (char-code (char-downcase letter))
     (char-code #\a)))

(defun previous-letter (letter)
  "B is the previous letter of C."
  (code-char (1- (char-code letter))))

(defun write-n-spaces (n)
  "write n spaces"
  (loop repeat n do (write-char #\space)))

(defun make-letter-list (start-letter)
  "Return a list of letters from A to start-letter"
  (loop for i from 0 upto (letter-value start-letter)
        collect (code-char (+ (char-code #\a) i))))

(defun write-letter (letter n-front n-back)
  "Write n-front spaces, then the letter, optionally insert some space and the letter again:
< n-front >letter< n-back >letter< n-front >"
  (write-n-spaces n-front)
  (write-char letter)
  (unless (char= letter #\a)
    (write-n-spaces (1- (* 2 n-back)))
    (write-char letter))
  (write-n-spaces n-front)
  (terpri))

;;; ================================================================
;;; Iterative Solution

(defun diamond-iter (letter)
  (loop with letters = (make-letter-list letter)
        with n = (length letters)
        for front downfrom (1- n)
        for back from 0
        for letter in letters do
        (write-letter letter front back))
  (loop with letters = (rest (reverse (make-letter-list letter)))
        with n = (length letters)
        for back downfrom (1- n)
        for front from 1
        for letter in letters do
        (write-letter letter front back)))

; (diamond-iter #\e)

;;; ================================================================
;;; Recursive Solution 1

(defun %diamond-rec (letters front back i n dir &aux (letter (first letters)))
  (cond ((= i n)
         (write-letter letter front 0))
        ((= i 1)
         (%diamond-rec (rest letters) (1+ front) (1- back) (1+ i) n :up)
         (write-letter letter 0 back)           
         (%diamond-rec (rest letters) (1+ front) (1- back) (1+ i) n :down))
        ((eq dir :up)
         (%diamond-rec (rest letters) (1+ front) (1- back) (1+ i) n :up)
         (write-letter letter front back))
        ((eq dir :down)
         (write-letter letter front back)
         (%diamond-rec (rest letters) (1+ front) (1- back) (1+ i) n :down))))

(defun diamond-rec (letter &aux (letters (reverse (make-letter-list letter))) (n (length letters)))
  (%diamond-rec letters 0 (1- n) 1 n :none))

; (diamond-rec #\e)

;;; ================================================================
;;; Recursive Solution 2

;;; Uses a local recursive function, variant of above

(defun diamond-rec2 (letter)
  (labels ((diamond-rec (letter front back i n dir
                         &aux (previous-letter (previous-letter letter)))
             (cond ((= i n)
                    (write-letter letter front 0))
                   ((= i 1)
                    (diamond-rec previous-letter (1+ front) (1- back) (1+ i) n :up)
                    (write-letter letter 0 back)           
                    (diamond-rec previous-letter (1+ front) (1- back) (1+ i) n :down))
                   ((eq dir :up)
                    (diamond-rec previous-letter (1+ front) (1- back) (1+ i) n :up)
                    (write-letter letter front back))
                   ((eq dir :down)
                    (write-letter letter front back)
                    (diamond-rec previous-letter (1+ front) (1- back) (1+ i) n :down)))))
    (let ((n (1+ (letter-value letter))))
      (diamond-rec letter 0 (1- n) 1 n :none)
      (values))))

; (diamond-rec2 #\e)

;;; ================================================================
;;; Solution with array combinators

(defmacro do-2d-times-array ((v0 v1 array) &body body)
  "Iterate variables v0 and v1 over a 2d array"
  (check-type v0 symbol)
  (check-type v1 symbol)
  `(loop for ,v0 from 0 below (array-dimension ,array 0) do
        (loop for ,v1 from 0 below (array-dimension ,array 1) do
              (progn ,(second body)))
        (progn ,(first body))))

(defmacro copy-2d-array (array array1 v0 v1 i j)
  "Copy array (iterating over variables v0 and v1) using target index expressions i and j."
  (check-type v0 symbol)
  (check-type v1 symbol)
  `(do-2d-times-array (,v0 ,v1 array)
     ()
     (setf (aref ,array1 ,i ,j) (aref ,array ,v0 ,v1))))

(defun show-2d-array (array)
  "Print a 2d array."
  (do-2d-times-array (i j array)
    (terpri)
    (write-char (aref array i j)))
  (values))

(defun make-letter-vector (letter
                           &aux
                           (value (letter-value (char-downcase letter)))
                           (v (make-array (1+ value))))
  "Make a vector from character a upto letter"
  (loop for i from 0 upto value
         do (setf (aref v i) (code-char (+ (char-code #\a) i))))
  v)

(defun make-diagonal-array (vector fill)
  (let* ((n (length vector))
         (2darray (make-array (list n n) :initial-element fill)))
    (loop for i from 0 and e across vector
        do (setf (aref 2darray i (- n i 1)) e))
    2darray))

(defun mirror-right (array)
  (let ((array1 (make-array (list (array-dimension array 0)
                                  (1- (* 2 (array-dimension array 1))))
                            :initial-element #\*)))
    (copy-2d-array array array1 i j i j)
    (copy-2d-array array array1 i j i (- (* 2 (array-dimension array 1)) j 2))
    array1))

(defun mirror-down (array)
  (let ((array1 (make-array (list (1- (* 2 (array-dimension array 0)))
                                  (array-dimension array 1))
                            :initial-element #\*)))
    (copy-2d-array array array1 i j i j)
    (copy-2d-array array array1 i j (- (* 2 (array-dimension array 0)) i 2) j)
    array1))

(defun diamond-array (letter)
  (show-2d-array
   (mirror-down
    (mirror-right
     (make-diagonal-array
      (make-letter-vector letter)
      #\space)))))

; (diamond-array #\e)

;;; ================================================================
;;; End of File