(ffi:clines "
#include <SDL2/SDL.h>

SDL_Renderer *renderer;
SDL_Window *window;
SDL_Event e;

const Uint8 *state;

int quitted;

int up_arrow, down_arrow, left_arrow, right_arrow;
")

(Defpackage "jam-no-theme" (:use cl) (:nicknames :ja))

(in-package :ja)
(defvar *SCREEN-WIDTH* 640)
(defvar *SCREEN-HEIGHT* 480)
(defvar *scale* '5)
(defvar *unit-width* (/ *screen-width* *scale*))
(defvar *unit-height* (/ *screen-height* *scale*))

;;;Underlying sdl2 mechanism
(defmacro game ((screen-width screen-height)
                (&rest unused)
                update-closures)
 `(let ((screen-width ,screen-width)
        (screen-height ,screen-height))
   ,(append '(declare) '((:int screen-width screen-height)))
   (multiple-value-bind
    (up down left right aa bb) (check-arrow-scancodes)
    (multiple-value-setq (*up* *down* *left* *right* *a* *B*)
                        (values up down left right aa bb)))
  (unwind-protect
   (ffi:c-progn (screen-width screen-height)
    "

if (SDL_Init(SDL_INIT_VIDEO) < 0) {
	SDL_LogError(SDL_LOG_CATEGORY_APPLICATION, 
	    \"Failed to init %s\",
	    SDL_GetError());
	" (error "failed to SDL_Init(video)") "
}

if (SDL_CreateWindowAndRenderer(#0,#1,SDL_WINDOW_RESIZABLE,
	&window, &renderer)) {
	SDL_LogError(SDL_LOG_CATEGORY_APPLICATION, 
	    \"Failed to create w & r%s\",
	    SDL_GetError());
	" (error "failed to create window and renderer") "
}

quitted = 0;
for (;;) {
	while(SDL_PollEvent(&e))
	    if (e.type == SDL_QUIT) quitted = 1;
	    else if (e.type == SDL_KEYDOWN)
	        switch (e.key.keysym.sym) {
	        case SDLK_q:
	            quitted = 1;
	            break;
	        }
	if (quitted) break;
	
	
	SDL_SetRenderDrawColor(renderer, 0, 10, 20, 255);
	SDL_RenderClear(renderer);
        "

        (mapc 'funcall ,update-closures)

	"
	SDL_RenderPresent(renderer);
	SDL_Delay(125);
}

SDL_DestroyRenderer(renderer);
SDL_DestroyWindow(window);
SDL_Quit();")
   (ffi:c-inline () () nil "SDL_Quit();"))))


;;; SDL_SetRenderDrawColor in lisp.
(defun set-color (r g b &optional (a 255))
 (ffi:c-inline (r g b a) (:int :int :int :int) nil
  "SDL_SetRenderDrawColor(renderer, #0, #1, #2, #3)"
  :one-liner t))

;;; SDL_RenderFillRect as a lisp function.
(defun fill-rectangle (x y w h)
 (ffi:c-inline ((* *scale* x) 
                (* *scale* y) 
                (* *scale* w)
                (* *scale* h))
  (:int :int :int :int) nil
  "
   SDL_RenderFillRect(renderer, 
       &(struct SDL_Rect){.x = #0, .y = #1, 
                          .w = #2, .h = #3})"
  :one-liner t))

;; Add plants.
(defvar *plants* (list)) 
(defun spawn-plant-in (x y w h)
 (push (list 'leaves (+ x (random w)) (+ y (random h)))
  *plants*))

(defparameter *leaves/flowers* 2/31)
(defparameter *flowers/berries* 2/21)
(defparameter *berry-satiation* 6)
(defvar *max-seeds* 4)
(defvar *seedbox* 5)

;; leaves->flowers flowers->berries
(defun advance-some-plants (&rest from-to-frac/tions)
 (setf *plants*
  (loop for plant in *plants* 
   nconc
   (or 
    (loop for (from to frac/tion) in from-to-frac/tions
     when (< (random (denominator frac/tion)) (numerator frac/tion))
     do
     (when (eq (car plant) from) (return `((,to ,@(cdr plant))))))
    `(,plant)))))

;; Painting the lilly
(defun paint-plants ()
 (loop for plant in *plants*
  for xy-position = (cdr plant)
  for color = (case (car plant)
               (leaves '(0 255 0))
               (flower '(255 0 255))
               (berry '(255 0 0)))
  when color
  do (apply 'set-color color)
     (apply 'fill-rectangle
      (append (mapcar '- xy-position 
               (funcall (ensure-player) :get-position t)
               (mapcar '- *orig-player-position*))
              '(1 1)))))

;;once the player/robots need to spawn, they should spawn from the base.
(defvar *base* nil)
(defvar *orig-player-position* (list (truncate *unit-width* 2) 
                                     (truncate *unit-height* 2)))
(defun ensure-base ()
 (or *base* 
  (setf *base* 
   (let ((xy-position '(1 2)) (color '(255 255 255)))
    (lambda (&key get-position move paint seed-plant create-bot)
     (cond (seed-plant)
           (get-position (values xy-position))
           (move (case move
                  (e (decf (car xy-position))) 
                  (n (incf (cadr xy-position))) 
                  (w (incf (car xy-position))) 
                  (s (decf (cadr xy-position)))))
           (create-bot (spawn-bot))
           (paint 
            (apply 'set-color color)
            (apply 'fill-rectangle
              (append (mapcar '- xy-position 
                       (funcall (ensure-player) :get-position t)
                       (mapcar '- *orig-player-position*))
               '(1 1))))))))))

(defun make-counter (&optional (default 5))
 (lambda (&key (increase nil) (check nil))
  (cond (check (values default))
   (increase (incf default increase))
   (t (decf default)))))

(defparameter *default-treasures* 10)
(defparameter *treasures* nil)

(defun ensure-treasures ()
 (if *treasures* *treasures* 
  (setf *treasures*
   (let ((locations (list)) (treasure-count (make-counter 0)))
    (lambda (&key paint generate collect devour treasure-meter count-treasure)
     (cond (count-treasure (funcall treasure-count :check t))
           (treasure-meter (loop initially (set-color 200 175 75)
                             for n below (funcall treasure-count :check t) do
                             (fill-rectangle n 5 1 5)))
           (paint (loop initially (When (null locations)
                                   (funcall *change-secret-image*)
                                   (loop repeat *default-treasures*
                                    for x = (- (random *unit-width*) 
                                               (truncate *unit-width* 2))
                                    for y = (- (random *unit-height*)
                                               (truncate *unit-height* 2))
                                    do (push (list x y) locations)))
                  for location in locations
                  for (x y) = (mapcar '- location 
                               (funcall (ensure-player) :get-position t) 
                               (mapcar '- *orig-player-position*))
                  for color = (loop repeat 3 collect (random 256))
                  do (apply 'set-color color)
                  do (apply 'fill-rectangle x y '(1 1))))
          (devour (when (member devour locations :test 'equal)
                   (setf locations (delete devour locations :test 'equal))
                   (funcall treasure-count :increase 1)
                   (values t)))))))))

;; controlled by arrowkeys.
(defvar *player* nil)
(defvar *player-starting-hunger* 20)
(defun ensure-player ()
 (if *player* *player*
  (setf *player* 
   (let ((xy-position (copy-list '(0 0)))
         (color '(255 255 0))
         (satiety (make-counter *player-starting-hunger*)))
    (lambda (&key get-position move paint consume hunger render-hunger)
     (cond (get-position (values xy-position))
           (render-hunger
            (loop initially (set-color 100 255 150)
             for n below (funcall satiety :check t) do
             (fill-rectangle (- n 6) 1 5 5)))
           (consume
            (funcall (ensure-treasures) :devour xy-position)
            (let ((flora (rassoc xy-position *plants* :test 'equal)))
             (when flora
              (when (eq 'berry (car flora))
               (setf *plants* (delete flora *plants* :test 'equal))
               (funcall satiety :increase *berry-satiation*)
               (funcall satiety :increase 
                (random (1+ (funcall (ensure-treasures) :count-treasure t))))
               (dotimes (n (random *max-seeds*))
                (let* ((xy (loop for m below 2 collect (+ (nth m xy-position) 
                                                       (- (random (* 2 *seedbox*))
                                                        *seedbox*))))
                       (flora (rassoc xy *plants* :test 'equal)))
                 (if flora
                  (progn
                   (setf *plants* (delete flora *plants* :Test 'equal))
                   (setf *plants* (push (rplaca flora 'leaves) *plants*)))
                  (setf *plants* (push `(leaves ,@xy) *plants*)))))))))
           (hunger (funcall satiety))
           (move (case move
                  (e (incf (car xy-position))) (n (decf (cadr xy-position))) 
                  (w (decf (car xy-position))) (s (incf (cadr xy-position)))))
           (paint (apply #'set-color color)
            (apply #'fill-rectangle `(,@*orig-player-position* 1 1)))))))))

;;Robot stuff
(defvar *default-program*
 '(lambda (self) (Funcall self :move (nth (random 4) '(e n w s)))))
(defparameter *programming* (eval *default-program*))

(defvar *bots* (list))
(defun spawn-bot (&key (program *programming*) (hunger 5)
                  (position (copy-list (funcall (ensure-base) :get-position t)))
                  (initial-memories (list)))
 (let ((new-bot
  (let ((xy-position position) (satiety hunger) (programming program)
        (color '(0 255 255)) (memories initial-memories))
   (lambda (&key paint perambulate hunger consume move)
    (cond (perambulate (funcall programming perambulate))
          (paint (apply 'set-color color)
           (let ((rect-args (append (mapcar '- xy-position 
                  (funcall (ensure-player) :get-position t)
                  (mapcar '- *orig-player-position*)) '(1 1))))
            (apply 'fill-rectangle rect-args)))
          (move (case move
                 (e (decf (car xy-position))) (n (incf (cadr xy-position))) 
                 (w (incf (car xy-position))) (s (decf (cadr xy-position)))))
          (hunger (decf satiety)) (memories memories)
          (consume (funcall (ensure-treasures) :devour xy-position)
           (when (rassoc xy-position *plants* :test 'equal)
            (when (eq (car (rassoc xy-position *plants* :test 'equal)) 'berry)
             (incf satiety *berry-satiation*)
             (incf satiety
              (random (1+ (funcall (ensure-treasures) :count-treasure t))))
             (setf *plants* (delete (rassoc xy-position *plants* :test 'equal) 
                             *plants*))
            (dotimes (n (random *max-seeds*))
             (let ((xy (loop for m below 2
                        collect (+ (nth m xy-position) 
                                 (- (random (* 2 *seedbox*)) *seedbox*)))))
              (if (rassoc xy *plants* :test 'equal)
               (rplaca (rassoc xy *plants* :test 'equal) 'leaves)
               (push (cons 'leaves xy) *plants*))))))))))))
  (push new-bot *bots*)))

(defvar *D34D8075* (list))
(defun queue-remove-bot (bot) (push bot *D34D8075*))
(defun delete-bots ()
 (setf *bots* (delete-if (lambda (bot) (member bot *D34D8075*)) *bots*)
  *D34D8075* (list)))

(defun mechanical-process (&optional (bots *bots*))
 (loop initially (funcall (ensure-base) :create-bot t)
  for bot in bots
  do (funcall bot :perambulate bot)
  do (funcall bot :consume t)
  do (funcall bot :paint t)
  when (zerop (funcall bot :hunger t))
  do (queue-remove-bot bot)
  finally (delete-bots)))

(defun get-key-state (scancode)
 (let ((state (ffi:c-inline (scancode) (:int) :int
               "state = SDL_GetKeyboardState(NULL);
                @(return) = (state[#0]) ? 1 : 0;")))
  (values state)))

(defun check-arrow-scancodes ()
 (ffi:c-inline () () (values :int :int :int :int :int :int :int :int)
  "@(return 0) = SDL_SCANCODE_UP;
   @(return 1) = SDL_SCANCODE_DOWN;
   @(return 2) = SDL_SCANCODE_LEFT;
   @(return 3) =  SDL_SCANCODE_RIGHT;
   @(return 4) =  SDL_SCANCODE_A;
   @(return 5) = SDL_SCANCODE_B;
   @(return 6) = SDL_SCANCODE_RETURN;"))

(defparameter *funs* (list))
(defun play-game () (game (*screen-width* *screen-height*) () *funs*))

(defun make-game () " Little-by-little game creation "
 ;; New game
 (defparameter *funs* (list))


 ;; Add lines in either direction
 ;; Add player and base
 (push (lambda ()  (Funcall (ensure-player) :paint t)) *funs*)
 (push (lambda () (Funcall (ensure-base) :paint t)) *funs*)
 (push
  (lambda () 
   (funcall (ensure-player) :move
    (cond ((not (zerop (get-key-state *down*)))  's)
          ((not (zerop (get-key-state *up*)))    'n)
          ((not (zerop (get-key-state *left*)))  'w)
          ((not (zerop (get-key-state *right*))) 'e))))
  *funs*)
 (loop repeat 10 do (spawn-plant-in -5 -5 15 15))
 (push 
  (lambda () 
   (advance-some-plants 
    `(leaves flower ,*leaves/flowers*) 
    `(flower berry ,*flowers/berries*))) 
  *funs*)
 (push (lambda () (funcall (ensure-player) :consume t)) *funs*)
 (push (lambda () (paint-plants)) *funs*)
 (push (lambda () (mechanical-process *bots*)) *funs*)
 (push (lambda () 
        (setf *player* 
         (and (not (zerop (funcall (ensure-player) :hunger t)))
          (ensure-player))))
  *funs*)
  (push (lambda () (funcall (ensure-player) :render-hunger t)) *funs*)
  (push (lambda () (funcall (ensure-treasures) :paint t)) *funs*)
  (push (lambda () (funcall (ensure-treasures) :treasure-meter t)) *funs*)
 
 ;; secret image - alright not very secret
 (push
  (lambda ()
   (loop initially (set-color 100 100 100)
    for b below 96 do
    (loop for a below 128 
     when (not (zerop (funcall *secret-image*))) do
     (fill-rectangle a b 1 1))))
   *funs*)
 (play-game))