heyarne.all-my-friends.app/src/heyarne/all_my_friends/views.cljs

(ns heyarne.all-my-friends.views
  (:require [reagent.core :as r]
            [cljs-http.client :as http]
            [cljs.core.async :refer [<! go]]
            [heyarne.all-my-friends.facemesh :refer [webcam-facemesh]]
            [heyarne.all-my-friends.visualize :as vis]))

;; minimalistic re-frame-like event handling

(defonce state (r/atom {:status :welcome-message}))

(declare dispatch)

(def events
  {:welcome/continue (fn [db _]
                       (assoc db :status :running))
   :running/snapshot (fn [db result]
                       (assoc-in db [:snapshots :current] result))
   :running/discard-snapshot (fn [db _]
                               (update db :snapshots dissoc :current))
   :upload/post (fn [db post-body]
                     ;; TODO: This is a bit dirty compared to the others because it
                     ;; shoehorns http requests and database changes together
                     (let [req (http/post "/upload" {:multipart-params post-body})]
                       (println "request started")
                       (go (let [{:keys [success body error-text] :as res} (<! req)]
                             (prn res)
                             (if success
                               (dispatch [:upload/done (:message body)])
                               (dispatch [:upload/error error-text]))
                             (println "request finished")))
                       (assoc db :in-progress? true)))
   :upload/error (fn [db message]
                   (dispatch [:message/show {:message message, :type :error}])
                   (dissoc db :in-progress?))
   :upload/done (fn [db _]
                  (dispatch [:message/show {:message "Tippi toppi!", :type :success}])
                  (dissoc db :in-progress?))
   :message/show (fn [db {:keys [message type]}]
                   (let [message-id (* (Math/random) (js/Date.now))]
                     (when (= type :success)
                       (js/window.setTimeout #(dispatch [:message/hide message-id]) 2500))
                     (assoc-in db [:messages message-id] {:type type
                                                          :message message})))
   :message/hide (fn [db message-id]
                   (update db :messages dissoc message-id))})

(defn dispatch [[event data]]
  (when-let [handler (events event)]
    (js/requestAnimationFrame #(swap! state handler data))))

;; views

(defn welcome-message [{:keys [hidden?]}]
  [:section#welcome-message
   {:class (str (when hidden? "hidden"))}
   [:h1 "Hi Freund!"]
   [:p "Ich habe eine kleine App gebaut, um mit einem komischen Gefühl umzugehen, dass sich in letzter Zeit bei mir eingestellt hat:
Seit der globalen Covid19-Pandemie sind wir alle dazu gezwungen, auf physischen Kontakt weitgehend zu verzichten. Ein Großteil der Zeit, die ich mit Freunden hat sich ins Digitale verlagert."]
   [:p "Das fühlt sich sicher bald komplett normal an -- vorher möchte ich aber gerne irgendwas mit dem Gefühl machen, das das hinterlässt. Wer ein Audiosample mit einem Frequenzbereich von bis zu 22 kHz aufnehmen möchte, muss auf 44 kHz samplen, und wer ein Foto mit einer Webcam macht bekommt... was jetzt genau?"]
   [:p "Du machst mit der App ein Selfie. Darauf wird etwas algorithmisches Voodoo gegossen und heraus kommt ein 3D-Modell, dass du mir schicken kannst."]
   [:button {:on-click #(dispatch [:welcome/continue])} "Klingt cool, weiter bitte"]])

(defn video-snapshot [video-elem]
  (let [canvas (js/document.createElement "canvas")
        ctx (.getContext canvas "2d")]
    (set! (.-width canvas) (.-videoWidth video-elem))
    (set! (.-height canvas) (.-videoHeight video-elem))
    (.drawImage ctx video-elem 0 0 (.-width canvas) (.-height canvas))
    (.getImageData ctx 0 0 (.-width canvas) (.-height canvas))))

(defn image-data->blob [img-data cb]
  (let [canvas (js/document.createElement "canvas")
        ctx (.getContext canvas "2d")]
    (set! (.-width canvas) (.-width img-data))
    (set! (.-height canvas) (.-height img-data))
    (.putImageData ctx img-data 0 0)
    (.toBlob canvas cb "image/png")))

(defn preview [{{:keys [video predictions]} :snapshot}]
  (let [canvas (js/document.createElement "canvas")
        ctx (.getContext canvas "2d")]
    ;; this is most probably not the most beautiful component i have ever written
    (set! (.-predictions js/window) predictions)
    (set! (.-width canvas) (.-width video))
    (set! (.-height canvas) (.-height video))
    (.putImageData ctx video 0 0)
    (vis/draw-wireframe ctx predictions)
    [:img {:src (.toDataURL canvas)}]))

(defn snapshot [{:keys [current-snapshot]}]
  (let [compliment (rand-nth ["Hübschi!" "Sweet." "Nice!" ":)" "Uh lala~"])]
    [:div#snapshot-preview.container
     [:p compliment]
     [preview {:snapshot current-snapshot}]
     [:button {:on-click #(image-data->blob (:video current-snapshot)
                                            (fn [blob]
                                              (dispatch
                                               [:upload/post {:snapshot blob
                                                              :predictions (js/JSON.stringify (:predictions current-snapshot))}])))}
      "Abschicken"]
     [:button {:on-click #(dispatch [:running/discard-snapshot])} "Lieber noch eins"]]))

(defn notifications [{:keys [messages]}]
  [:ul.notifications
   (for [[id {:keys [type message]}] messages]
     ^{:key id} [:li.message {:class (name type)
                              :on-click #(dispatch [:message/hide id])} message])])

(defn running [{:keys [on-faces-detected halt?]}]
  (let [result (atom {:video nil
                      :predictions nil})]
    (fn [{:keys [on-faces-detected halt?]}]
      [:div.container
       [:p "Tippe auf den Button um ein Bild zu machen."]
       [webcam-facemesh {:on-faces-detected (fn [ctx video predictions]
                                              (swap! result assoc
                                                     :video video
                                                     :predictions predictions)
                                              (on-faces-detected ctx predictions))
                         :halt? halt?}]
       [:button {:on-click #(dispatch [:running/snapshot (update @result :video video-snapshot)])} "Cheese"]])))

(defn app []
  (let [state @state
        status (:status state)
        messages (:messages state)
        current-snapshot (get-in state [:snapshots :current])
        uploading? (some? (get-in state [:http/requests "/upload"]))]
    (prn messages)
    [:<>
     [welcome-message {:hidden? (not= :welcome-message status)}]
     [notifications {:messages messages}]
     (when uploading?
       [:p "Bild wird hochgeladen"])
     (when current-snapshot
       [snapshot {:current-snapshot current-snapshot}])
     (case status
       :permission-rejected [:div "Sad :("]
       :running [running {:on-faces-detected vis/draw-sketch
                          :halt? (some? current-snapshot)}]
       ;; default
       nil)]))