Skip to content
Find file
Fetching contributors…
Cannot retrieve contributors at this time
306 lines (252 sloc) 8.89 KB
(ns cljminecraft.blocks
(:require [cljminecraft.logging :as log]
[cljminecraft.items :as i]
[cljminecraft.player :as plr]
[cljminecraft.bukkit :as bk]))
(defn left-face [key]
({:up :up, :down :down
:north :east, :east :south
:south :west, :west :north} key))
(defn right-face [key]
({:up :up, :down :down
:north :west, :west :south
:south :east, :east :north} key))
(defn opposite-face [key]
({:up :down, :down :up
:north :south, :south :north
:east :west, :west :east} key))
(defn find-relative-dir [d r]
({:north d :south (opposite-face d) :east (left-face d) :west (right-face d) :up :up :down :down} r))
(defmulti run-action (fn [ctx a] (:action a)))
(defn run-actions [ctx & actions]
(loop [a (first actions)
r (rest actions)
context ctx]
(cond
(nil? a) context
(and (coll? a) (not (map? a))) (recur (first a) (concat (rest a) r) context)
:else
(recur (first r) (rest r) (run-action context a)))))
(defmacro defaction [name docstring ctx-binding params & method-body]
(let [params (map #(symbol (.getName (symbol %))) params)]
`(do
(defn ~name ~docstring [~@params]
(zipmap [:action ~@(map keyword params)] [~(keyword name) ~@params]))
(defmethod run-action ~(keyword name) [~ctx-binding {:keys [~@params]}]
~@method-body))))
(defaction move
"Move the current point in a direction"
{:keys [origin material painting?] :as ctx} [direction distance]
(let [[direction distance]
(if (neg? distance) ;; If we're negative, do the opposite thing.
[(opposite-face direction) (Math/abs distance)]
[direction distance])
d (find-relative-dir (:direction ctx) direction)
startblock (.getBlock origin)
m (i/get-material material)]
(when painting?
(doseq [i (range (or distance 1))]
(doto (.getRelative startblock (get i/blockfaces d) i)
(.setData 0)
(.setType (.getItemType m))
(.setData (.getData m)))))
(assoc ctx :origin (.getLocation (.getRelative startblock (get i/blockfaces d) (or distance 1))))))
(defn forward [& [x]]
(move :north x))
(defn back [& [x]]
(move :south x))
(defn left [& [x]]
(move :east x))
(defn right [& [x]]
(move :west x))
(defn up [& [x]]
(move :up x))
(defn down [& [x]]
(move :down x))
(defaction turn
"Turn the direction the current context is facing"
{:keys [direction] :as ctx} [relativedir]
(assoc ctx :direction (find-relative-dir direction relativedir)))
(defn turn-left []
(turn :east))
(defn turn-right []
(turn :west))
(defn turn-around []
(turn :south))
(defaction pen
"Do something with the 'pen', set whether it should paint as you move or not"
ctx [type]
(case type
:up (assoc ctx :painting? false)
:down (assoc ctx :painting? true)
:toggle (assoc ctx :painting? (not (:painting? ctx)))))
(defn pen-up []
(pen :up))
(defn pen-down []
(pen :down))
(defn pen-toggle []
(pen :toggle))
(defaction pen-from-mark
"Restore the pen state from mark"
ctx [mark]
(assoc :ctx :painting? (get-in ctx [:marks mark :painting?] true)))
(defaction material
"Set the current material to paint with"
ctx [material-key]
(assoc ctx :material material-key))
(defaction fork
"Run actions with ctx but don't update current ctx - effectively a subprocess"
ctx [actions]
(run-actions ctx actions)
ctx)
(defaction mark
"Stow away the state of a context into a given key"
{:keys [marks] :as ctx} [mark]
(assoc ctx :marks (assoc marks mark (dissoc ctx marks))))
(defn gen-mark []
(.toString (java.util.UUID/randomUUID)))
(defaction jump
"Jump your pointer to a given mark"
{:keys [marks] :as ctx} [mark]
(merge ctx (get marks mark {})))
(defaction copy
"copy a sphere of a given radius into a mark"
{:keys [marks origin] :as ctx} [mark radius]
(let [distance (* radius radius)
copy-blob
(doall
(for [x (range (- 0 radius) (inc radius))
y (range (- 0 radius) (inc radius))
z (range (- 0 radius) (inc radius))
:when (<= (+ (* x x) (* y y) (* z z)) distance)]
[x y z (.getData (.getState (.getRelative (.getBlock origin) x y z)))]))
m (get-in ctx [:marks mark] {})]
(assoc ctx :marks (assoc marks mark (assoc m :copy {:blob (doall copy-blob)})))))
(defaction cut
"Cut a sphere of a given radius into a mark"
ctx [mark radius]
(let [{:keys [origin material] :as ctx} (run-action ctx (copy mark radius))
mat (i/get-material material)
distance (* radius radius)]
(doseq [x (range (- 0 radius) (inc radius))
y (range (- 0 radius) (inc radius))
z (range (- 0 radius) (inc radius))
:when (<= (+ (* x x) (* y y) (* z z)) distance)]
(let [block (.getRelative (.getBlock origin) x y z)]
(.setTypeIdAndData block (.getItemTypeId mat) (.getData mat) false)))
ctx))
(defaction paste
"Paste a previously copied or cut block against a mark"
{:keys [origin] :as ctx} [mark]
(let [{:keys [blob]} (get-in ctx [:marks mark :copy] {})]
(doseq [[x y z data] blob]
(let [block (.getRelative (.getBlock origin) x y z)]
(.setTypeIdAndData block (.getItemTypeId data) (.getData data) false)))
ctx))
(defn location-to-point [origin point]
[(- (.getX point) (.getX origin))
(- (.getY point) (.getY origin))
(- (.getZ point) (.getZ origin))])
(defaction copy-to-mark
"Copy a block to a mark"
{:keys [origin marks] :as ctx} [mark]
(let [[px py pz] (location-to-point origin (:origin (get marks mark)))
copy-blob
(doall
(for [x (range (min px 0) (max px 0))
y (range (min py 0) (max py 0))
z (range (min pz 0) (max pz 0))]
[x y z (.getData (.getState (.getRelative (.getBlock origin) x y z)))]))
m (get-in ctx [:marks mark] {})]
(assoc ctx :marks (assoc marks mark (assoc m :copy {:blob (doall copy-blob)})))))
(defaction cut-to-mark
"Cut a block to a mark, replacing everything with a given material or air if not provided"
ctx [mark]
(let [{:keys [origin marks material] :as ctx} (run-action ctx (copy-to-mark mark))
mat (i/get-material material)
[px py pz] (location-to-point origin (:origin (get marks mark)))]
(doseq [x (range (min px 0) (max px 0))
y (range (min py 0) (max py 0))
z (range (min pz 0) (max pz 0))]
(let [block (.getRelative (.getBlock origin) x y z)]
(.setTypeIdAndData block (.getItemTypeId mat) (.getData mat) false)))
ctx))
(defaction clear-mark
"Clears a mark"
ctx [mark]
(update-in ctx [:marks mark] {}))
(defn calcline
"This returns a set of points for a line"
[xt yt zt]
(if (= [xt yt zt] [0 0 0])
'([0 0 0])
(let [q (max (Math/abs xt) (Math/abs yt) (Math/abs zt))
m (/ yt q)
n (/ zt q)
o (/ xt q)]
(for [qi (range q)]
[(Math/round (double (* o qi)))
(Math/round (double (* m qi)))
(Math/round (double (* n qi)))]))))
;; to be finished......
(defaction line-to-mark
"Draw a line directly to a given mark from current point"
{:keys [origin material marks] :as ctx} [mark]
(let [originblock (.getBlock origin)
mat (i/get-material material)
point (location-to-point origin (:origin (get marks mark)))
linepoints (apply calcline point)]
(doseq [[x y z] linepoints]
(let [block (.getRelative originblock x y z)]
(.setTypeIdAndData block (.getItemTypeId mat) (.getData mat) false)))
ctx))
(defn line
"Draw a line, relative to current position and direction"
[fwd lft u]
(let [m (gen-mark)]
[(mark m)
(pen :up)
(forward fwd)
(left lft)
(up u)
(pen :down)
(line-to-mark m)
(clear-mark m)]))
(defn extrude [direction x & actions]
(for [c (range x)]
(fork
{:action :move :direction direction :distance c}
actions)))
(defn setup-context [player-name]
{:origin (.getLocation (plr/get-player player-name))
:direction :north
:material :wool
:painting? true
:marks {}})
(comment
(def ctx (setup-context (first (.getOnlinePlayers (bk/server)))))
(defn floor-part []
[(forward 5) (turn-right) (forward 1) (turn-right) (forward 5) (turn-left) (forward 1) (turn-left)])
(defn floor []
[(floor-part) (floor-part) (floor-part) (floor-part) (floor-part) (floor-part) (floor-part) (floor-part)])
(run-actions ctx
(material :air)
(floor) (turn-around) (up) (floor))
(run-actions
ctx
(material :air)
(extrude
:up 10
(forward 10) (right 10) (back 8) (left 2) (back 2) (left 8))
)
(run-actions
ctx
;(material :air)
(line 10 10 10)
(line 1 2 3)
(line -5 0 0)
(line 0 -5 0)
(line 0 0 -5))
(bk/ui-sync
@cljminecraft.core/clj-plugin
#(run-actions ctx (material :air) (mark :start) (left 100) (forward 100) (up 40) (cut-to-mark :start) (clear-mark :start))))
Something went wrong with that request. Please try again.