etype/etype.el

(require 'cl)

(defvar etype-words-in-play nil)

(defvar etype-unused-words nil)

(defvar etype-score 0)

(defvar etype-in-game nil)

(defvar etype-timers nil)

(defvar etype-overlay nil)

(defvar etype-point-max nil)

(defvar etype-completing-word nil)

(defconst etype-lines-file "etype.lines")

(defun etype-read-file ()
  "Returns a vector of lines from the 'etype-lines-file'."
  (with-temp-buffer
    (insert-file-contents (expand-file-name etype-lines-file default-directory))
    (apply
     'vector
     (split-string
      (buffer-substring-no-properties (point-min) (point-max)) "\n"))))

(defun init-game ()
  "Sets up the game grid containing 'fill-column' number of spaces and 30
lines. Also some variables are set."
  (let ((space (make-string fill-column ? )))
    (dotimes (i 30)
      (insert space)
      (newline))
    (setq etype-point-max (point))
    (insert (make-string fill-column ?-))
    (insert "\nScore: 0"))
  (goto-char (point-min))
  (setq etype-score 0)
  (setq etype-in-game t)
  ;; Shuffle the vector returned from etype-read-file, and turns it in to a
  ;; list.
  (setq etype-unused-words (mapcar 'eval (shuffle-vector (etype-read-file)))))

(defun etype-fit-word (word)
  "Returns a point that a word can be inserted on the next
line. If there is no room (a word is directly beneath it) it
tries to find the nearest point it could fit. If there is no room
NIL is returned, and the word is not moved."
  (let* ((point (point))
         (space (make-string (+ 2 (length word)) ? )))
    (if (and (or (looking-back " ") (bolp)) (looking-at space))
        point
      (let* ((backward (search-backward space (point-at-bol) t))
             (backward (and backward (+ backward 1))))
        (goto-char point)
        (let* ((forward (search-forward space (point-at-eol) t))
               (forward (and forward (- forward (- (length space) 1)))))
          (cond ((not backward) forward)
                ((not forward) backward)
                ((< (- point backward) (- forward point)) backward)
                (t forward)))))))

(defun etype-search-timers (word)
  (first
   (remove-if-not
    (lambda (timer)
      (member word (timer--args timer))) etype-timers)))

(defun etype-move-word (point word)
  (when etype-in-game
    (let ((moving-word-at-point (string= word (current-word t)))
          (search-string (buffer-substring-no-properties point (point))))
      (save-excursion
        (goto-char point)
        (unless (looking-at word)
          (beginning-of-buffer)
          (search-forward word etype-point-max)
          (backward-word))
        (let ((point (point))
              (timer (etype-search-timers word)))
          (next-line)
          (let* ((len (length word))
                 (space (make-string len ? ))
                 (destination (etype-fit-word word)))
            (when destination
              (goto-char point)
              (delete-char len)
              (insert space)
              (goto-char destination)
              (delete-char len)
              (insert word)
              (setf (timer--args timer) (list destination word))))))
      (when moving-word-at-point
        (search-forward-regexp (concat "\\<" search-string))
        (save-excursion
          (let ((point (point)))
            (backward-word)
            (move-overlay etype-overlay (point) point)))))))

(defun etype-random ()
  (let ((random (abs (random))))
    (* 0.5 (/ random (expt 10.0 (floor (log random 10)))))))

(defun etype-get-word (&optional count)
  (let ((word (pop etype-unused-words)))
    (if (null (member
               (string-to-char word)
               (mapcar 'string-to-char etype-words-in-play)))
        word
      (add-to-list 'etype-unused-words word t)
      (unless (and count (> count 5))
        (etype-get-word (if count (+ count 1) 1))))))

(defun etype-spawn-word ()
  (save-excursion
    (when etype-in-game
      (let* ((word (etype-get-word))
             (point (random (- fill-column (length word)))))
        (when word
          (goto-char point)
          (let ((point (etype-fit-word word)))
            (when point
              (goto-char point)
              (delete-char (length word))
              (insert word)
              (push word etype-words-in-play)
              (let ((random (etype-random)))
                (push
                 (run-at-time random random 'etype-move-word point word)
                 etype-timers)))))))))

(defun etype-move-shooter (column)
  (save-excursion
    (end-of-buffer)
    (previous-line)
    (delete-region (point-at-bol) (point-at-eol))
    (insert (make-string (- fill-column 5) ?-))
    (beginning-of-line)
    (let* ((shooter " /.\\ ")
           (len (length shooter)))
      (cond ((and (> column 1) (< column (- fill-column (+ len 1))))
             (forward-char (- column 2)))
            ((> column (- fill-column (+ len 1)))
             (forward-char (- fill-column len))))
      (insert shooter))))

(defun etype-shoot (&optional steps)
  (let* ((bullet-dest (+ (- etype-point-max
                            (* (or steps 0) (+ fill-column 1)))
                         (current-column)))
         (overlay (make-overlay bullet-dest (+ bullet-dest 1))))
    (etype-move-shooter (current-column))
    (overlay-put overlay 'face (cons 'background-color "white"))
    (sit-for (* 0.000005 (or steps 0)))
    (delete-overlay overlay)
    (when (< (point) bullet-dest)
      (etype-shoot (+ (or steps 0) 1)))))

(defun etype-loop ()
  (push (run-at-time 0 1 'etype-spawn-word) etype-timers))

(defun etype-search-word (key-etyped)
  (setq etype-completing-word
        (search-forward-regexp
         (concat
          "\\<" (single-key-description last-input-event))
         etype-point-max t))
  (when etype-completing-word
    (etype-shoot)
    (setq etype-overlay
          (make-overlay (- etype-completing-word 1) etype-completing-word))
    (overlay-put etype-overlay 'face '(:inherit isearch))))

(defun etype-continue-word (key-typed)
  (when (looking-at key-typed) (forward-char)
        (move-overlay etype-overlay (overlay-start etype-overlay) (point))
        (etype-shoot)
        (when (looking-at " ")
          (etype-clear-word)
          (setq etype-completing-word nil))))

(defun etype-clear-word ()
  (delete-overlay etype-overlay)
  (etype-move-shooter (/ fill-column 2))
  (let* ((word (current-word t))
         (len (length word))
         (space (make-string len ? )))
    (backward-word)
    (let ((timer (etype-search-timers word)))
      (cancel-timer timer)
      (setq etype-timers (remove timer etype-timers)))
    (setq etype-words-in-play
          (remove word etype-words-in-play))
    (add-to-list 'etype-unused-words word t)
    (delete-char len)
    (insert space)
    (incf etype-score (* len 1.5)))
  (search-forward "Score: ")
  (delete-char (- (point-max) (point)))
  (insert (number-to-string etype-score))
  (goto-char (point-min)))

(defun etype-catch-input ()
  (interactive)
  (let ((key-typed (single-key-description last-input-event)))
    (if etype-completing-word
        (etype-continue-word key-typed)
      (etype-search-word key-typed))))

(defun etype ()
  (interactive)
  (switch-to-buffer "Etype")
  (etype-mode)
  (init-game)
  (etype-loop))

(defun etype-cleanup ()
  (mapc 'cancel-timer etype-timers))

(define-derived-mode etype-mode nil "Etype"
  "A mode for playing Etype."
  (make-local-variable 'etype-score)
  (make-local-variable 'etype-timers)
  (make-local-variable 'etype-overlay)
  (make-local-variable 'etype-in-game)
  (make-local-variable 'etype-point-max)
  (make-local-variable 'etype-unused-words)
  (make-local-variable 'etype-words-in-play)
  (make-local-variable 'etype-completing-word)
  (define-key (current-local-map)
    [remap self-insert-command] 'etype-catch-input)
  (add-hook 'kill-buffer-hook 'etype-cleanup))