BlockCad v1

;;;;;;;;;;;;;;
;;; Levels ;;;
;;;;;;;;;;;;;;

(setq levels (list
  (list
    1 1 1 1 1 1 1 1 1 1
    1 0 0 0 1 3 0 0 0 1
    1 0 2 0 1 1 1 0 0 1
    1 0 0 0 0 0 0 0 0 1
    1 0 0 0 0 0 0 0 0 1
    1 0 0 0 0 0 0 0 0 1
    1 0 0 0 0 0 0 0 0 1
    1 0 0 0 0 0 0 0 0 1
    1 0 0 0 0 0 0 0 0 1
    1 1 1 1 1 1 1 1 1 1
  )

  (list
    1 1 1 1 1 1 1 1 1 1
    1 0 0 0 0 0 0 0 0 1
    1 0 2 0 0 0 0 0 0 1
    1 0 0 2 0 0 0 0 0 1
    1 0 0 0 0 0 0 0 0 1
    1 0 0 0 0 0 0 0 0 1
    1 0 0 0 0 0 0 0 0 1
    1 0 0 3 0 0 0 0 0 1
    1 0 0 3 0 0 0 0 0 1
    1 1 1 1 1 1 1 1 1 1
  )

  (list
    1 1 1 1 1 1 1 1 1 1
    1 0 0 0 0 0 0 0 0 1
    1 0 0 0 0 0 0 0 0 1
    1 0 0 0 0 0 0 0 0 1
    1 0 0 0 0 2 0 0 0 1
    1 0 0 0 0 0 2 0 0 1
    1 0 0 0 0 0 0 0 0 1
    1 0 0 0 0 2 0 1 3 1
    1 0 0 0 0 0 3 1 3 1
    1 1 1 1 1 1 1 1 1 1
  )

  (list
    1 1 1 1 1 1 1 1 1 1
    1 0 0 0 0 1 0 0 0 1
    1 0 0 0 0 1 0 0 0 1
    1 0 0 2 0 1 0 0 0 1
    1 0 3 2 0 0 0 0 0 1
    1 0 0 2 3 0 0 0 0 1
    1 0 0 0 0 1 3 0 0 1
    1 0 0 0 0 1 0 0 0 1
    1 0 0 0 0 1 0 0 0 1
    1 1 1 1 1 1 1 1 1 1
  )
))

;;;;;;;;;;;;;;;;;;;;;;;;
;;; Action constants ;;;
;;;;;;;;;;;;;;;;;;;;;;;;

(setq
  action_none  0
  action_up    1
  action_down  2
  action_left  3
  action_right 4
  action_reset 5
)

;;;;;;;;;;;;;
;;; UTILS ;;;
;;;;;;;;;;;;;

(defun nth-replace ( pos new-item lst )
  (if (null lst)
    nil
    (cons
      (if (eq pos 0) new-item (car lst))
      (nth-replace (1- pos) new-item (cdr lst))
    )
  )
)

(DEFUN SETUP ()
  (COMMAND "OSNAP" "OFF")
)

;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Level control API ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;

(DEFUN GET_LEVEL_STATIC (id)
  (subst 0 2 (nth id levels))
)

(DEFUN GET_LEVEL (id)
  (subst 0 3 (nth id levels))
)

(DEFUN GET_BLOCK_AT (scene x y size)
  (nth (+ x (* y size)) scene)
)

(DEFUN SET_BLOCK_AT (scene x y size new-block)
  (nth-replace (+ x (* y size)) new-block scene)
)

(DEFUN RESET_SCENE (level)
  (GET_LEVEL level)
)

(DEFUN VALIDATE_POS (x y size)
  (and
    (and (>= x 0) (< x size))
    (and (>= y 0) (< y size))
  )
)

(DEFUN COMPARE_SCENES (scene_dynamic scene_static / i block_static block_dynamic)
  (setq i 0)
  (setq result T)
  (while (< i (length scene_dynamic))
    (setq block_dynamic (nth i scene_dynamic))
    (setq block_static (nth i scene_static))

    (if (= block_dynamic 2)
      (if (/= block_static 3)
        (progn
      (setq result nil)
      (setq i (length scene_dynamic))
    )
      )
    )

    (setq i (1+ i))
  )

  result
)

;;;;;;;;;;;;;;;
;;; Drawing ;;;
;;;;;;;;;;;;;;;

(DEFUN GRID (count spacing color / x len)
  (COMMAND "COLOR" color)
  (setq len (* count spacing))

  (setq x 0)

  (while (>= count 0)
    (setq count (1- count))

    (COMMAND "LINE" (list x 0) (list x len) "")
    (COMMAND "LINE" (list 0 x) (list len x) "")

    (setq x (+ x spacing))
  )
)

(DEFUN DRAW_BLOCK (x y size spacing color / drawx drawy p1 p2 p3 p4)
  (setq drawx (* x spacing))
  (setq drawy (* (- (1- size) y) spacing))

  (setq p1 (list drawx drawy))
  (setq p2 (list (+ drawx spacing) drawy))
  (setq p3 (list drawx (+ drawy spacing)))
  (setq p4 (list (+ drawx spacing) (+ drawy spacing)))

  (COMMAND "COLOR" color)
  (COMMAND "SOLID" p1 p2 p3 p4 "")
)

(DEFUN RENDER_BUTTON (x y size action)
  (COMMAND "RECTANG" (list x y) (list (+ x size) (+ y size)))

  (if (= action action_down)
      (COMMAND "LINE" (list x (+ y size)) (list (+ x (/ size 2)) y) (list (+ x size) (+ y size)) "")
  )

  (if (= action action_up)
      (COMMAND "LINE" (list x y) (list (+ x (/ size 2)) (+ y size)) (list (+ x size) y) "")
  )

  (if (= action action_left)
      (COMMAND "LINE" (list (+ x size) (+ y size)) (list x (+ y (/ size 2))) (list (+ x size) y) "")
  )

  (if (= action action_right)
      (COMMAND "LINE" (list x y) (list (+ x size) (+ y (/ size 2))) (list x (+ y size)) "")
  )

  (if (= action action_reset)
      (COMMAND "CIRCLE" "2P" (list x (+ y (/ size 2))) (list (+ x size) (+ y (/ size 2))))
  )
)

(DEFUN POINT_IN_RECT (point x y w h / px py)
  (setq px (nth 0 point)
    py (nth 1 point))

  (and
    (and (> px x) (> py y) )
    (and (< px (+ x w)) (< py (+ y h)) )
  )
)

(DEFUN RENDER_CONTROLS ()
  (RENDER_BUTTON -30 50 10 action_up)
  (RENDER_BUTTON -30 30 10 action_down)
  (RENDER_BUTTON -40 40 10 action_left)
  (RENDER_BUTTON -20 40 10 action_right)
  (RENDER_BUTTON -30 10 10 action_reset)
)

(DEFUN RENDER_SCENE (scene scene_static size spacing / x y current total block)
  (GRID size spacing "White")

  (setq current 0)
  (setq total (* size size))
  (setq x 0 y 0)

  (while (< current total)
    (setq block (GET_BLOCK_AT scene x y size))
    (setq block_static (nth current scene_static))

    (if (= block_static 3)
      (DRAW_BLOCK x y size spacing "Cyan")
    )

    (if (= block 1)
      (DRAW_BLOCK x y size spacing "White")
    )

    (if (= block 2)
      (DRAW_BLOCK x y size spacing "Red")
    )

    (setq x (1+ x))
    (if (>= x size)
    (setq x 0 y (1+ y))
    )

    (setq current (1+ current))
  )
)

(DEFUN RESET ()
  (COMMAND "ERASE" "ALL" "")
)

;;;;;;;;;;;;;;;;;;;;;;;;
;;; Game interaction ;;;
;;;;;;;;;;;;;;;;;;;;;;;;

(DEFUN PARSE_CLICK (point)
  (cond ((POINT_IN_RECT point -30 50 10 10) action_up)
    ((POINT_IN_RECT point -30 30 10 10) action_down)
    ((POINT_IN_RECT point -40 40 10 10) action_left)
    ((POINT_IN_RECT point -20 40 10 10) action_right)
    ((POINT_IN_RECT point -30 10 10 10) action_reset)
    (t action_none)
  )
)

(DEFUN HANDLE_ACTION (action scene size level)
  (cond
    ((= action action_up)    (MOVE_UP scene size))
    ((= action action_down)  (MOVE_DOWN scene size))
    ((= action action_left)  (MOVE_LEFt scene size))
    ((= action action_right) (MOVE_RIGHT scene size))
    ((= action action_reset) (RESET_SCENE level))
    (t scene)
  )
)

(DEFUN MOVE_UP (scene size / x y new_scene block block_destination)
  (setq x 0 y 0)
  (setq new_scene scene)

  (while (< y size)
    (setq block (GET_BLOCK_AT new_scene x y size))

    (cond
      ((and (VALIDATE_POS x (1- y) size) (= block 2))
       (setq block_destination (GET_BLOCK_AT new_scene x (1- y) size))

       (cond ((= block_destination 0)
     (setq new_scene (SET_BLOCK_AT new_scene x (1- y) size 2))
     (setq new_scene (SET_BLOCK_AT new_scene x y size 0))
       ))
      )
    )

    (setq x (1+ x))
    (cond ((>= x size)
      (setq y (1+ y))
      (setq x 0)
    ))
  )

  new_scene
)

(DEFUN MOVE_DOWN (scene size / x y new_scene block block_destination)
  (setq x 0 y (1- size))
  (setq new_scene scene)

  (while (>= y 0)
    (setq block (GET_BLOCK_AT new_scene x y size))

    (cond
      ((and (VALIDATE_POS x (1+ y) size) (= block 2))
       (setq block_destination (GET_BLOCK_AT new_scene x (1+ y) size))

       (cond ((= block_destination 0)
     (setq new_scene (SET_BLOCK_AT new_scene x (1+ y) size 2))
     (setq new_scene (SET_BLOCK_AT new_scene x y size 0))
       ))
      )
    )

    (setq x (1+ x))
    (cond ((>= x size)
      (setq y (1- y))
      (setq x 0)
    ))
  )

  new_scene
)

(DEFUN MOVE_LEFT (scene size / x y new_scene block block_destination)
  (setq x 0 y 0)
  (setq new_scene scene)

  (while (< x size)
    (setq block (GET_BLOCK_AT new_scene x y size))

    (cond
      ((and (VALIDATE_POS (1- x) y size) (= block 2))
       (setq block_destination (GET_BLOCK_AT new_scene (1- x) y size))

       (cond ((= block_destination 0)
     (setq new_scene (SET_BLOCK_AT new_scene (1- x) y size 2))
     (setq new_scene (SET_BLOCK_AT new_scene x y size 0))
       ))
      )
    )

    (setq y (1+ y))
    (cond ((>= y size)
      (setq x (1+ x))
      (setq y 0)
    ))
  )

  new_scene
)

(DEFUN MOVE_RIGHT (scene size / x y new_scene block block_destination)
  (setq x size y 0)
  (setq new_scene scene)

  (while (>= x 0)
    (setq block (GET_BLOCK_AT new_scene x y size))

    (cond
      ((and (VALIDATE_POS (1+ x) y size) (= block 2))
       (setq block_destination (GET_BLOCK_AT new_scene (1+ x) y size))

       (cond ((= block_destination 0)
     (setq new_scene (SET_BLOCK_AT new_scene (1+ x) y size 2))
     (setq new_scene (SET_BLOCK_AT new_scene x y size 0))
       ))
      )
    )

    (setq y (1+ y))
    (cond ((>= y size)
      (setq x (1- x))
      (setq y 0)
    ))
  )

  new_scene
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Program loop          ;;;
;;; Usage (command): game ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(DEFUN c:game ()
  (setq current_level 0)
  (setq current_scene (GET_LEVEL current_level))
  (setq current_scene_static (GET_LEVEL_STATIC current_level))

  (SETUP)

  (setq loop 1)
  (while (= loop 1)
    (RESET)
    (RENDER_SCENE current_scene current_scene_static 10 10)
    (RENDER_CONTROLS)

    (setq point (getpoint "\n click a button: "))
    (setq action (PARSE_CLICK point))
    (prompt (strcat (itoa action)))
    (setq current_scene (HANDLE_ACTION action current_scene 10 current_level))
    (if (COMPARE_SCENES current_scene current_scene_static)
      (progn
    (setq current_level (1+ current_level))
    (setq current_scene (GET_LEVEL current_level))
    (setq current_scene_static (GET_LEVEL_STATIC current_level))
      )
    )

    (if (>= current_level (length levels))
      (progn
    (setq loop 0)
    (alert "Well done! You've completed the game.\n\nBlockCad v1 by ekgame\n2014-12-13")
      )
    )
  )
)