(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))

You are viewing proxied material from tilde.institute. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.