flan/examples/textures-image-processing.flan

;;;; raylib [textures] example - image processing
;;;;
;;;; examples/textures/textures_image_processing.c. The one example in the
;;;; category where the CPU does the work: nine filters run over a pixel
;;;; buffer in RAM, and the GPU's only job is to show the answer. Every other
;;;; textures example this tree has ported either generates pixels and uploads
;;;; them once (image-generation), draws into a render target (fog-of-war,
;;;; mouse-painting), or reads one back (mouse-painting again). None of them
;;;; had ever handed raylib a buffer and asked it to rewrite the buffer.
;;;;
;;;; What that puts under load, and it is a different thing from the nine
;;;; Gen* calls in examples/textures-image-generation.flan: **in-place
;;;; mutation of an Image through a (Ptr Image)**. Eight of the nine filters
;;;; take the image by pointer and change `data` under the caller —
;;;; image-format and image-blur-gaussian *reallocate* it, so the pointer the
;;;; caller held before the call is freed by it. raylib.flan's Images section
;;;; already says that the by-value/by-pointer split is raylib's own and is
;;;; kept deliberately so a caller can see which calls change what they are
;;;; given; this is the example that depends on it being right.
;;;;
;;;; What needed adding: `PixelFormat`, a defenum in vendor/raylib/raylib.flan,
;;;; with image-format moved from the generated half to the hand-written one
;;;; and mapped in `bindings` so its twenty-four members are checked against
;;;; raylib.h. The C's line is
;;;;
;;;;     ImageFormat(&imOrigin, PIXELFORMAT_UNCOMPRESSED_R8G8B8A8);
;;;;
;;;; and without the enum the Flan for it is `7`, which is a number with
;;;; nothing in it to say which of twenty-four conversions was meant. It is
;;;; the same trade TextureFilter made for the fog-of-war port. The call is
;;;; kept even though the generated image is already in that format — raylib's
;;;; Gen* calls all produce it — because it is the C's own guard and because
;;;; the reason it is there (UpdateTexture will not take anything else) has
;;;; not stopped being true.
;;;;
;;;; **The source image is generated and not loaded, and that is a licence
;;;; decision rather than a technical one.** The C loads `resources/parrots.png`,
;;;; which raylib's own examples/textures/resources/LICENSE.md lists with no
;;;; author and no licence at all, so it is not a file to copy into this
;;;; repository. The three textures examples already here generate everything
;;;; they draw and this one joins them. What the generated image has to be is
;;;; set by the filters rather than by taste: **asymmetric in both axes**, or
;;;; the vertical and the horizontal flip look identical and the port appears
;;;; broken, and carrying **sharp edges**, or the Gaussian blur has nothing to
;;;; soften. A diagonal gradient with three solid shapes dropped on it at
;;;; three different distances from three different edges is the smallest
;;;; thing that is both.
;;;;
;;;; The other deviation is the size. parrots.png is 768x512; this is 200x150,
;;;; because a blur of radius 10 is the one filter here whose cost is visible
;;;; and because the picture is a demonstration of the filter rather than the
;;;; point of the program.
;;;;
;;;; One gap, written up in docs/PORTING.md and since closed: LoadImageColors
;;;; answers a (Ptr Color) and UpdateTexture used to take only a (Ptr u8),
;;;; because the header spells its parameter `const void *` and the importer
;;;; had to render that as something. `reload-texture` below spelled the cast
;;;; by hand — the address of the first field of the first pixel, which is the
;;;; same address said at length. It does not any more: the header check
;;;; accepts a pointer to anything where the header says `void *`, so the
;;;; package binds the call twice and the caller names the type it has.

(import rl "vendor:raylib")

(defconst screen-width  800)
(defconst screen-height 450)

(defconst num-processes 9)

;; The C's ImageProcess enum. Flan's defenum lowers to an i32 for C's benefit
;; and these never cross to C, so they are defconsts — the same choice
;; examples/textures-image-generation.flan made for its texture index.
(defconst proc-none             0)
(defconst proc-color-grayscale  1)
(defconst proc-color-tint       2)
(defconst proc-color-invert     3)
(defconst proc-color-contrast   4)
(defconst proc-color-brightness 5)
(defconst proc-gaussian-blur    6)
(defconst proc-flip-vertical    7)
(defconst proc-flip-horizontal  8)

(defonce process-names [num-processes string])

;; The nine toggle buttons down the left-hand side, laid out once at startup.
(defonce toggle-recs [num-processes rl/Rectangle])

;; The generated picture's size. Small on purpose — see the header comment.
(defconst source-width  200)
(defconst source-height 150)

;; The picture the filters run over, in place of the C's parrots.png.
;;
;; The gradient runs corner to corner rather than along an axis, so a flip in
;; either direction moves it, and the three shapes are at three different
;; distances from three different edges so that no reflection of this image is
;; this image. The rectangles are what the blur has to work on: a gradient is
;; already smooth and a blur of it is very nearly itself.
;;
;; Exported rather than local because test/programs/raylib-image-processing.flan
;; runs the same nine filters over the same pixels with no window open, and a
;; headless case asserting a *different* image would be asserting nothing.
(defn make-source-image [] rl/Image
  (let [img (rl/gen-image-gradient-linear source-width source-height 45
                                          rl/skyblue rl/darkblue)]
    (rl/image-draw-rectangle (addr img) 12 10 62 34 rl/red)
    (rl/image-draw-rectangle (addr img) 24 96 44 44 rl/lime)
    (rl/image-draw-circle    (addr img) 152 112 26 rl/gold)
    img))

;; The C's `switch (currentProcess)`. A cond here, as in
;; examples/textures-image-generation.flan, and for the same reason: Flan has
;; no switch and the chain reads the same.
;;
;; Every arm takes the image by pointer and every arm rewrites the buffer the
;; pointer names. `proc-none` is the C's `default: break` and does nothing at
;; all, which is what makes the top entry of the list "NO PROCESSING" rather
;; than a filter that happens to be the identity.
(defn apply-process [img (Ptr rl/Image)  which i32] ()
  (cond
    (= which proc-color-grayscale)  (rl/image-color-grayscale img)
    (= which proc-color-tint)       (rl/image-color-tint img rl/green)
    (= which proc-color-invert)     (rl/image-color-invert img)
    (= which proc-color-contrast)   (rl/image-color-contrast img -40.0)
    (= which proc-color-brightness) (rl/image-color-brightness img -80)
    (= which proc-gaussian-blur)    (rl/image-blur-gaussian img 10)
    (= which proc-flip-vertical)    (rl/image-flip-vertical img)
    (= which proc-flip-horizontal)  (rl/image-flip-horizontal img)))

(defonce texture rl/Texture2D)
(defonce im-origin rl/Image)
(defonce im-copy rl/Image)
(defonce current-process i32)
(defonce mouse-hover-rec i32)

;; Throw the working copy away, take a fresh one from the original, run the
;; filter over it, and push the result at the texture that is already on the
;; GPU.
;;
;; The round trip through LoadImageColors is the C's, and it is not the
;; shortest route: after image-format the working image is already RGBA8, so
;; `(.data im-copy)` is the same bytes and is already a (Ptr u8). It is kept
;; because it is what the C does and because the pair is the only thing in the
;; corpus that exercises it.
;;
;; The awkward step in it is gone. LoadImageColors answers a (Ptr Color) and
;; UpdateTexture's parameter is `const void *`, which the importer has to
;; render as *something* and renders as (Ptr u8) — so the call used to be
;; written `(addr (.r (at (slice-from-ptr pixels n) 0)))`: the address of the
;; red channel of pixel zero, which is the address of the buffer said the long
;; way round. A `void *` is opaque about what it points at by construction,
;; and the header check now knows that, so the package can offer the same C
;; function under the element type the caller actually has.
;; update-texture-colors is that binding and this is its only caller.
(defn reload-texture [] ()
  (rl/unload-image im-copy)
  (set im-copy (rl/image-copy im-origin))
  (apply-process (addr im-copy) current-process)
  (let [pixels (rl/load-image-colors im-copy)]
    (rl/update-texture-colors texture pixels)
    (rl/unload-image-colors pixels)))

(defn main [] ()
  (rl/init-window screen-width screen-height
                  "raylib [textures] example - image processing")
  (defer (rl/close-window))

  (set (at process-names 0) "NO PROCESSING")
  (set (at process-names 1) "COLOR GRAYSCALE")
  (set (at process-names 2) "COLOR TINT")
  (set (at process-names 3) "COLOR INVERT")
  (set (at process-names 4) "COLOR CONTRAST")
  (set (at process-names 5) "COLOR BRIGHTNESS")
  (set (at process-names 6) "GAUSSIAN BLUR")
  (set (at process-names 7) "FLIP VERTICAL")
  (set (at process-names 8) "FLIP HORIZONTAL")

  ;; NOTE, as the C has it: a texture can only be made after init-window,
  ;; because making one needs the GL context init-window creates. The image
  ;; underneath it does not — nothing above this line touches the GPU.
  (set im-origin (make-source-image))
  (rl/image-format (addr im-origin) :pixel-uncompressed-r8g8b8a8)
  (set texture (rl/load-texture-from-image im-origin))
  (set im-copy (rl/image-copy im-origin))

  (defer (rl/unload-texture texture))
  (defer (rl/unload-image im-origin))
  (defer (rl/unload-image im-copy))

  (set current-process proc-none)
  (set mouse-hover-rec -1)

  (set toggle-recs (array num-processes rl/Rectangle))
  (dotimes [i num-processes]
    (set (at toggle-recs i)
         (rl/Rectangle {.x 40.0  .y (f32 (+ 50 (* 32 i)))
                        .width 150.0  .height 30.0})))

  (rl/set-target-fps 60)

  (until (rl/window-should-close?)
    ;; Update
    ;;
    ;; The C computes mouseHoverRec with a loop whose `else` clause resets it
    ;; on every miss and whose `break` leaves it set on a hit. As in
    ;; examples/textures-mouse-painting.flan the reset is lifted out in front
    ;; and the loop only ever sets it, which is the same answer said plainly —
    ;; the nine rectangles do not overlap, so there is no first-hit-wins rule
    ;; to preserve.
    (set mouse-hover-rec -1)
    (let [reload false]
      (dotimes [i num-processes]
        (when (rl/collision-point-rec? (rl/get-mouse-position) (at toggle-recs i))
          (set mouse-hover-rec i)
          (when (rl/mouse-button-released? :mouse-left)
            (set current-process i)
            (set reload true))))

      ;; The keyboard half of the same toggle group. DOWN wraps at the end of
      ;; the list; UP does not wrap to the end but to 7, which is the C's own
      ;; off-by-one — FLIP HORIZONTAL is unreachable going up — and is left
      ;; as it is because changing it here would make this file disagree with
      ;; the example it claims to be.
      (cond
        (rl/key-pressed? :key-down)
        (do (set current-process (+ current-process 1))
            (when (> current-process (- num-processes 1))
              (set current-process 0))
            (set reload true))

        (rl/key-pressed? :key-up)
        (do (set current-process (- current-process 1))
            (when (< current-process 0) (set current-process 7))
            (set reload true)))

      ;; NOTE, as the C has it: image processing is a costly thing to do per
      ;; frame. It is done here only when the selection changed, and a program
      ;; that needed it every frame would do it on the GPU in a shader.
      (when reload (reload-texture)))

    ;; Draw
    (rl/with-drawing
      (rl/clear-background rl/raywhite)

      (rl/draw-text "IMAGE PROCESSING:" 40 30 10 rl/darkgray)

      (dotimes [i num-processes]
        (let [on (or (= i current-process) (= i mouse-hover-rec))
              r  (at toggle-recs i)
              name (at process-names i)]
          (rl/draw-rectangle-rec r (if on rl/skyblue rl/lightgray))
          (rl/draw-rectangle-lines (i32 (.x r)) (i32 (.y r))
                                   (i32 (.width r)) (i32 (.height r))
                                   (if on rl/blue rl/gray))
          ;; Centred in the button, so the label's own measured width is what
          ;; decides where it starts.
          (rl/draw-text name
                        (i32 (- (+ (.x r) (/ (.width r) 2.0))
                                (/ (f32 (rl/measure-text name 10)) 2.0)))
                        (+ (i32 (.y r)) 11)
                        10
                        (if on rl/darkblue rl/darkgray))))

      (let [x (- screen-width (.width texture) 60)
            y (- (/ screen-height 2) (/ (.height texture) 2))]
        (rl/draw-texture texture x y rl/white)
        (rl/draw-rectangle-lines x y (.width texture) (.height texture)
                                 rl/black)))))