412 PurelyFunctional.tv Newsletter

00 Land perimeter.md

Land perimeter

A grid of 1s and 0s shows the location of land and water. A 1 represents a square full of land, a 0 represents a square full of water. Your job is to calculate the perimeter of the land, both as it touches water and touches the edge.

A grid with a single square filled with land has a perimeter of 4, since there are four sides:

(perimeter [[1]]) ;=> 4

Likewise, a single square filled with water has a perimeter of 0:

(perimeter [[0]]) ;=> 0

Two squares of land next to each other share an edge, which reduces the perimeter:

(perimeter [[1 1]]) ;=> 6

The edge of the grid is like an implicit encircling of water:

(perimeter [[1 1]
            [1 1]]) ;=> 8
(perimeter [[0 0 0 0]
            [0 1 1 0]
            [0 1 1 0]
            [0 0 0 0]]) ;=> 8 (same!)

Here are some other weird shapes:

(perimeter [[1 1 1 1 1 1]
            [1 0 0 0 0 1]
            [1 0 1 1 0 1]
            [1 0 0 0 0 1]
            [1 1 1 1 1 1]]) ;=> 42

(perimeter [[0 1 0 0]
            [1 1 1 0]
            [0 1 0 0]
            [1 1 0 0]]) ;=> 16

Thanks to this site for the challenge idea where it is considered Expert in JavaScript. The problem has been modified from the original.

Please submit your solutions as comments on this gist.

(defn land-coords [y row]
  (keep-indexed #(when (= 1 %2) [%1 y]) row))

(defn neighbours [[x y]]
  [[(dec x) y] [(inc x) y] [x (dec y)] [x (inc y)]])

(defn perimeter [rows]
  (let [lands (reduce into #{} (map-indexed land-coords rows))]
    (->> lands (mapcat neighbours) (remove lands) count)))

(ns tst.demo.core
  (:use tupelo.core tupelo.test)
  (:require
    [tupelo.array :as arr]))  ; Docs:  https://cljdoc.org/d/tupelo/tupelo/21.01.26b/api/tupelo.array

(defn pad-array
  [x]
  (let [nrows0 (arr/num-rows x)
        zcol   (arr/create nrows0 1 0)
        x1     (arr/glue-horiz zcol x zcol)

        ncols1 (arr/num-cols x1)
        zrow   (arr/create 1 ncols1 0)
        x2     (arr/glue-vert zrow x1 zrow)]
    x2))

(def padded-2x3
  [[0 0 0 0 0]
   [0 1 2 3 0]
   [0 4 5 6 0]
   [0 0 0 0 0]])

(dotest
  (is= padded-2x3
    (pad-array [[1 2 3]
                [4 5 6]])))

(defn count-edges
  [x i j]
  (let [edge-val-count #(if (zero? %) 1 0)
        top            (get-in x [(dec i) j])
        bottom         (get-in x [(inc i) j])
        left           (get-in x [i (dec j)])
        right          (get-in x [i (inc j)])
        edge-counts    (mapv edge-val-count
                         [top bottom left right])
        edges-found    (apply + edge-counts)]
    edges-found))

(dotest
  (is= 2 (count-edges padded-2x3 1 1))
  (is= 1 (count-edges padded-2x3 1 2)))

(defn land?
  [x i j]
  (not (zero? (get-in x [i j]))))

(defn perimeter
  [world-in]
  (let [world  (pad-array world-in)
        nrow   (arr/num-rows world)
        ncol   (arr/num-cols world)

        counts (forv [i (range nrow)
                      j (range ncol)
                      :when (land? world i j)] ; also filters out first/last row & col
                 (count-edges world i j))
        result (apply + 0 counts)]
    result))

(dotest
  (is= 0 (perimeter [[0]]))
  (is= 4 (perimeter [[1]]))
  (is= 6 (perimeter [[1 1]]))

  (is= 8 (perimeter [[1 1]
                     [1 1]]))
  (is= 8 (perimeter
           [[0 0 0 0]
            [0 1 1 0]
            [0 1 1 0]
            [0 0 0 0]]))
  (is= 42 (perimeter
            [[1 1 1 1 1 1]
             [1 0 0 0 0 1]
             [1 0 1 1 0 1]
             [1 0 0 0 0 1]
             [1 1 1 1 1 1]]))

  (is= 16 (perimeter
            [[0 1 0 0]
             [1 1 1 0]
             [0 1 0 0]
             [1 1 0 0]])))

Another solution, this time using partition-by:

(defn parts [xs]
  (->> (concat [0] xs [0]) (partition-by identity) rest))

(defn perimeter [rows]
  (->> rows (apply map vector) (concat rows) (mapcat parts) count))

Note this solution assumes all input rows are the same length i.e. the "world" is rectangular.

(defn count-terrain-changes-for-row [row]
  (loop [[current-cell & cells] row
         previous-cell 0
         total-changes 0]
    (if (nil? current-cell)
      (if (= 1 previous-cell)
        (inc total-changes)
        total-changes)
      (if (= current-cell previous-cell)
        (recur cells current-cell total-changes)
        (recur cells current-cell (inc total-changes))))))

(defn perimeter [terrain]
  (let [cols (apply mapv vector terrain)] ;transpose row->cols
    (->> (into terrain cols)
         (map count-terrain-changes-for-row)
         (reduce +))))

soooooo many if statements... Learn from @steffan-westcott 2nd example how to do this in a more clojure way

...and another solution (also assuming equal length rows), this time using dedupe:

(defn perimeter [rows]
  (->> rows (apply map vector) (concat rows) (transduce (mapcat dedupe) +) (* 2)))

(defn perimeter [grid]
  (reduce + 0 (for [i (range (count grid))
                    :let [row (nth grid i)]
                    j (range (count row))
                    :when (pos? (nth row j))]
                (- 4
                   (nth row (inc j) 0)
                   (nth row (dec j) 0)
                   (get-in grid [(dec i) j] 0)
                   (get-in grid [(inc i) j] 0)))))

(defn changes [v]
  (->>
    (concat [0] v [0])
    (partition 2 1)
    (map (fn [[v1 v2]] (if (= v1 v2) 0 1)))
    (apply +)))


(defn perimeter [rows]
  (let [horizontal (apply + (map changes rows))
        vertical   (apply + (map changes (apply mapv vector rows)))]
    (+ horizontal vertical)))

Great problem! there is typo

(preimeter [[0 1 0 0]
            [1 1 1 0]
            [0 1 0 0]
            [1 1 0 0]]) ;=> 16

Unable to resolve symbol: preimeter in this context

My approach was to generate segments representing the top/left/right/bottom boundaries of each piece of land, remove the duplicate segments and count the remaining ones:

(defn land-segments [x y]
  [[x y (inc x) y] [(inc x) y (inc x) (inc y)]
   [x y x (inc y)] [x (inc y) (inc x) (inc y)]])

(defn grid-segments [lines]
  (let [width  (count (first lines))
        height (count lines)]
    (for [i (range width)
          j (range height)
          :when (= 1 (get-in lines [j i]))]
      (land-segments i j))))

(defn perimeter [lines]
  (let [segments (grid-segments lines)]
    (->> (mapcat seq segments)
         frequencies
         (filter (fn [[_ v]] (= 1 v)))
         count)))

(comment

  (perimeter [[1 1]
              [1 1]]) ;=> 8

  (perimeter [[0 0 0 0]
              [0 1 1 0]
              [0 1 1 0]
              [0 0 0 0]]) ;=> 8 (same!)

  (perimeter [[1 1 1 1 1 1]
              [1 0 0 0 0 1]
              [1 0 1 1 0 1]
              [1 0 0 0 0 1]
              [1 1 1 1 1 1]]) ;=> 42

  (perimeter [[0 1 0 0]
              [1 1 1 0]
              [0 1 0 0]
              [1 1 0 0]]) ;=> 16
  )

(defn neighbour-coords [x y]
  (map (partial map +)
       [[0 -1] [1 0] [0 1] [-1 0]]
       (repeat [x y])))

(defn adjacent-land [land-map x y]
  (->> (neighbour-coords x y)
       (map #(get-in land-map (reverse %) 0))
       (apply +)))

(defn perimeter [land-map]
  (->> (for [y     (range (count land-map))
             x     (range (count (first land-map)))
             :let  [v (get-in land-map [y x])
                    land-around (adjacent-land land-map x y)]
             :when (= v 1)]
         (- 4 land-around))
       (apply +)))

(defn perimeter [grid]
  (letfn [(cell-value [cell x y]
            (if (= 0 cell)
              0
              ;; assume an initial cell perimeter value of 4, then deduct 2 for
              ;; each shared boundary with preceding (i.e. north/west)
              ;; neighbours
              (- 4
                 (* 2 (get-in grid [(dec y) x] 0))
                 (* 2 (get-in grid [y (dec x)] 0)))))]
    (->> grid
         (map-indexed (fn [y row] (map-indexed (fn [x cell] (cell-value cell x y)) row)))
         (apply concat)
         (reduce +))))

Refactoring some other solutions and going for performance...

(defn perimeter [grid]
  (let [width (count (nth grid 0))
        v (persistent! (transduce cat conj! (transient []) grid))]
    (* 2 (transduce (map-indexed (fn [n x]
                                   (cond (zero? x) 0
                                         (zero? (rem n width)) (- 2 (nth v (- n width) 0))
                                         :else (- 2 (nth v (dec n)) (nth v (- n width) 0)))))
                    +
                    v))))

(defn- flip [x]
  (if (= 0 x) 1 0))

(defn x-count [xs]
  (count (first xs)))

(def y-count count)

(defn isolate-h [xs]
  (mapv #(into [] (concat [0] % [0])) xs))

(defn isolate-v [xs]
  (let [x-fill (repeat (x-count xs) 0)]
    (-> (into [] (cons (into [] x-fill) xs))
        (conj (into [] x-fill)))))

(defn isolate [xs]
  (-> xs
      (isolate-v)
      (isolate-h)))

(defn select-cell [xs [x y]]
  (let [x-max (dec (x-count xs))
        y-max (dec (y-count xs))]
    (if (and (>= x 0) 
             (<= x x-max)
             (>= y 0)
             (<= y y-max)) 
      (nth (nth xs y) x)
      0)))

(defn compute [xs x y]
  (if (= 1 (select-cell xs [x y]))
    (->> (list [x (dec y)] [x (inc y)] [(dec x) y] [(inc x) y])
         (map (partial select-cell xs))
         (map flip)
         (reduce +))
    0))

(defn perimeter [board]
  (let [island (isolate board)]
    (->> (for [y (range (y-count island))
               x (range (x-count island))] (compute island x y))
         (reduce +))))

(defn border
  "There is only a border if a and b are not equal"
  [a b]
  (if (not (= a b)) 1 0))

(defn count-line [s]
  (first
   (reduce (fn [[borders-in-line l] n]
             [(+ borders-in-line (border l n)) n])
           [0 0]
           (conj s 0))))

(defn transpose [s] (apply map vector s))

(defn perimeter [s]
  (letfn [(count-borders [s] (reduce + (map count-line s)))]
    (+ (count-borders s)
       (count-borders (transpose s)))))

(comment
  (count-line [0])
  (count-line [1])
  (count-line [1 0 1 0 1 1])

  (transpose [[1 1 1 0]
              [0 1 1 0]
              [0 1 1 0]
              [0 0 0 0]])

  (perimeter [[1]]) ;=> 4

  (perimeter [[0]]) ;=> 0

  (perimeter [[1 1]
              [1 1]]) ;=> 8

  (perimeter [[0 0 0 0]
              [0 1 1 0]
              [0 1 1 0]
              [0 0 0 0]]) ;=> 8 (same!)

  (perimeter [[1 1 1 1 1 1]
              [1 0 0 0 0 1]
              [1 0 1 1 0 1]
              [1 0 0 0 0 1]
              [1 1 1 1 1 1]]) ;=> 42

  (perimeter [[0 1 0 0]
              [1 1 1 0]
              [0 1 0 0]
              [1 1 0 0]]) ;=> 16
  ;;
  )

The perimeter of a single land square is 4 minus the number of surrounding land squares.
The multiplication by the square value works because land/water happens to have values 1/0, but this would be a bit too cute for production code. A simple if would be more readable.
Also, in production code I would split out the helper functions - here I just wanted to keep everything in a single form.

(defn perimeter [grid]
  (let [get-at (fn [[x y]]
                 (-> grid
                     (nth y [])
                     (nth x 0)))

        neighbours (fn [[x y]]
                     [[(dec x) y]
                      [x (inc y)]
                      [(inc x) y]
                      [x (dec y)]])

        perim (fn [loc]
                (* (get-at loc)
                   (- 4 (->> (neighbours loc)
                             (map get-at)
                             (reduce +)))))

        coords (for [x (range (count (first grid)))
                     y (range (count grid))]
                 [x y])]
    (->> coords
         (map perim)
         (reduce +))))

(defn all-coordinates [rows]
  (cartesian-product
   (range (count rows))
   (range (count (first rows)))))

(defn neighbours [[x y]]
  [[(dec x) y] [(inc x) y]
   [x (dec y)] [x (inc y)]])

(defn free-edges [grid coord]
  (->> (neighbours coord)
       (keep #(get-in grid %))
       (reduce +)
       (- 4)))

(defn perimeter [grid]
  (->> (all-coordinates grid)
       (remove #(zero? (get-in grid %)))
       (map #(free-edges grid %))
       (apply +)))