gnu-emacs-sources
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

bubbles.el 0.1


From: Ulf Jasper
Subject: bubbles.el 0.1
Date: Sun, 11 Feb 2007 22:03:19 +0100
User-agent: Gnus/5.11 (Gnus v5.11) Emacs/22.0.91 (gnu/linux)

This is bubbles.el, an implementation of the "Same Game" for Emacs,
similar to "Same GNOME" and many others, see
http://en.wikipedia.org/wiki/SameGame.

Version 0.1 provides the basic functionality for playing. Further
versions will add some eye candy and so on. It has been tested on GNU
Emacs 22 and 21.

Enjoy!

 ulf

PS: As far as I know there is no other implementation of the "Same
    Game" for Emacs. Please correct me if I'm wrong.

;;; bubbles.el --- Same Game for Emacs.

;; Copyright (C) 2007 Ulf Jasper

;; This file is NOT part of GNU Emacs.

;; Author:      Ulf Jasper <address@hidden>
;; Filename:    bubbles.el
;; URL:         http://de.geocities.org/ulf_jasper/emacs
;; Created:     5. Feb. 2007
;; Keywords:    Games
;; Time-stamp:  "11. Februar 2007, 21:50:16 (ulf)"
;; CVS-Version: $Id: bubbles.el,v 1.3 2007-02-11 20:50:30 ulf Exp $

;; ======================================================================

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2 of the License, or (at
;; your option) any later version.

;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software Foundation,
;; Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.

(defconst bubbles-version "0.1" "Version number of bubbles.el.")

;; ======================================================================

;;; Commentary:

;; Bubbles is an implementation of the "Same Game" for Emacs, similar
;; to "Same GNOME" and many others, see
;; http://en.wikipedia.org/wiki/SameGame.

;; Installation
;; ------------

;; Add the following line to your Emacs startup file (`~/.emacs').
;; (add-to-list 'load-path "/path/to/bubbles/")
;; (autoload 'bubbles "bubbles" "Play Bubbles" t)

;; ======================================================================

;;; History:

;; 0.1 (2007-02-11)
;;     Initial release. Tested with GNU Emacs 22.0.93 and 21.4.1.

;; ======================================================================

;;; Code:

(require 'gamegrid)

(defvar bubbles-grid-width
  15
  "Width of Bubbles grid.")

(defvar bubbles-grid-height
  10
  "Height of Bubbles grid.")

(defvar bubbles-chars
  [?+ ?O ?# ?X]
  "Characters used for bubbles.")

(defvar bubbles-empty-char
  ? 
  "Character for removed bubbles.")

(defvar bubbles-shift-mode
  'default
  "Game mode.
Available modes are `default' and`shifter'.")

(defvar bubbles--score
  0
  "Current Bubbles score.")

(defvar bubbles--neighbourhood-score
  0
  "Score of active bubbles neighbourhood.")

(defun bubbles--post-command ()
  "Command run after each movement."
  (bubbles--mark-neighbourhood))

(defvar bubbles-mode-map
  (make-sparse-keymap 'bubbles-mode-map))

(define-key bubbles-mode-map "q" 'bubbles-quit)
(define-key bubbles-mode-map "\n" 'bubbles-plop)
(define-key bubbles-mode-map " " 'bubbles-plop)
(define-key bubbles-mode-map [double-down-mouse-1] 'bubbles-plop)
(define-key bubbles-mode-map [mouse-2] 'bubbles-plop)

(defun bubbles-mode ()
  "Major mode for playing bubbles.
\\{bubbles-mode-map}"
  (kill-all-local-variables)
  (use-local-map bubbles-mode-map)
  (setq major-mode 'bubbles-mode)
  (setq mode-name "Bubbles")
  (setq buffer-read-only t)
  ;;(setq buffer-undo-list t)
  (add-hook 'post-command-hook 'bubbles--post-command t t))

(defun bubbles ()
  "Play Bubbles game."
  (interactive)
  (bubbles--initialize)
  )

(defun bubbles-quit ()
  "Quit Bubbles."
  (interactive)
  (message "bubbles-quit")
  (bury-buffer))

(defun bubbles--initialize ()
  "Initialize Bubbles game."
  (switch-to-buffer (get-buffer-create "*bubbles*"))
     (let ((inhibit-read-only t)
           (col-offset (max 0 (/ (- (window-width) bubbles-grid-width) 2)))
           (row-offset (max 0 (/ (- (window-height) bubbles-grid-height 2) 2))))
       (set-buffer-modified-p nil)
       (erase-buffer)
       (insert (make-string row-offset ?\n))
       (add-text-properties (point-min) (point) (list 'intangible t 'row -1
                                                      'col -1))
       (let ((i 0)
             (max-char (length bubbles-chars)))
         (while (< i bubbles-grid-height)
           (let ((p (point)))
             (insert (make-string col-offset ? ))
             (add-text-properties p (point) (list 'intangible t 'row i
                                                  'col -1)))
           (let ((j 0))
             (while (< j bubbles-grid-width)
               (let ((char (aref bubbles-chars (random max-char))))
               (insert char)
               (add-text-properties (1- (point)) (point) (list 'row i
                                                               'col j)))
               (setq j (1+ j))))
           (insert "\n")
           (setq i (1+ i)))
         (insert "\n")
         (insert (make-string col-offset ? ))))
     (bubbles-mode)
     (bubbles--reset-score)
     (bubbles--goto 0 0))

(defun bubbles--goto (row col)
  "Move point to bubble at coordinates ROW and COL."
  (if (or (< row 0) (< col 0)
          (>= row bubbles-grid-height) (>= col bubbles-grid-width))
      ;; error. return nil
      nil
    ;; go
    (goto-char (point-min))
    (let ((r (or (get-text-property (point) 'row) -1))
          (c (or (get-text-property (point) 'col) -1)))
      (while (< r row)
        (forward-line 1)
        (setq r (or (get-text-property (point) 'row) r)))
      (setq c (or (get-text-property (point) 'col) -1))
      (while (< c col)
        (forward-char 1)
        (setq c (or (get-text-property (point) 'col) c))))
    (point)))

(defun bubbles--char-at (row col)
  "Return character at bubble ROW and COL."
  (save-excursion
    (if (bubbles--goto row col)
        (char-after (point))
      nil)))

(defun bubbles--mark-neighbourhood (&optional pos)
  "Mark neighbourhood of point.
Use optional parameter POS instead of point if given."
  (unless pos (setq pos (point)))
  (let ((char (char-after pos))
        (inhibit-read-only t)
        (row (get-text-property (point) 'row))
        (col (get-text-property (point) 'col)))
    (add-text-properties (point-min) (point-max) '(face default
                                                        active nil))
    (when (and row col (not (eq char bubbles-empty-char)))
      (let ((count (bubbles--mark-direct-neighbours row col char)))
        (if (> count 1)
            (save-excursion
              (goto-char (point-min))
              (while (not (eobp))
                (if (get-text-property (point) 'active)
                    (put-text-property (point) (1+ (point)) 'face 'highlight))
                (forward-char))))
        (bubbles--update-neighbourhood-score count)))))

(defun bubbles--neighbourhood-available ()
  "Return t if another valid neighbourhood is available."
  (catch 'found
    (save-excursion
      (let ((i 0))
        (while (< i bubbles-grid-height)
          (let ((j 0))
            (while (< j bubbles-grid-width)
              (let ((c (bubbles--char-at i j)))
                (if (and (not (eq c bubbles-empty-char))
                         (or (eq c (bubbles--char-at (1+ i) j))
                             (eq c (bubbles--char-at i (1+ j)))))
                    (throw 'found t)))
              (setq j (1+ j))))
          (setq i (1+ i))))
      nil)))


(defun bubbles--reset-score ()
  "Reset bubbles score."
  (setq bubbles--neighbourhood-score 0
        bubbles--score 0)
  (bubbles--update-score))

(defun bubbles--update-score ()
  "Calculate and display new bubble score."
  (setq bubbles--score (+ bubbles--score bubbles--neighbourhood-score))
  (bubbles--show-scores))

(defun bubbles--update-neighbourhood-score (size)
  "Calculate and display score of active neighbourhood from its SIZE."
  (if (> size 1)
      (setq bubbles--neighbourhood-score (expt (- size 1) 2))
    (setq bubbles--neighbourhood-score 0))
  (bubbles--show-scores))

(defun bubbles--show-scores ()
  "Display current scores."
  (save-excursion
    (goto-char (or (next-single-property-change (point-min) 'status)
                   (point-max)))
    (let ((inhibit-read-only t)
          (pos (point)))
      (delete-region (point) (point-max))
      (let ((c (current-column)))
        (insert (format "Selected: %4d\n" bubbles--neighbourhood-score))
        (insert (make-string c ? ))
        (insert (format "Score:    %4d" bubbles--score))
        (put-text-property pos (point) 'status t)))))

(defun bubbles--game-over ()
  "Finish bubbles game."
  (save-excursion
    (bubbles--goto (/ bubbles-grid-height 2) 0)
    (let* ((inhibit-read-only t)
           (message "Game Over")
           (len (length message)))
      (forward-char (/ (- bubbles-grid-width len) 2))
      (delete-char len)
      (insert message))
    (goto-char (or (next-single-property-change (point-min) 'status)
                   (point-max)))
    (let ((inhibit-read-only t)
          (pos (point))
          (c (current-column)))
      (delete-region (point) (point-max))
      (insert "\n")
      (insert (make-string c ? ))
      (insert (format "Score:    %4d" bubbles--score))))
  (gamegrid-add-score (format "bubbles-%s-%d-%d-%d-scores"
                              (symbol-name bubbles-shift-mode)
                              (length bubbles-chars)
                              bubbles-grid-width bubbles-grid-height)
                      bubbles--score))

(defun bubbles--mark-direct-neighbours (row col char)
  "Mark direct neighbours of bubble at ROW COL with same CHAR."
  (save-excursion
    (let ((count 0))
      (when (and (bubbles--goto row col)
                 (eq char (char-after (point)))
                 (not (get-text-property (point) 'active)))
        (put-text-property (point) (1+ (point)) 'active t)
        (setq count (+ 1
                       (bubbles--mark-direct-neighbours row (1+ col) char)
                       (bubbles--mark-direct-neighbours row (1- col) char)
                       (bubbles--mark-direct-neighbours (1+ row) col char)
                       (bubbles--mark-direct-neighbours (1- row) col char))))
      count)))

(defun bubbles-plop ()
  "Remove active bubbles region."
  (interactive)
  (let ((inhibit-read-only t))
    ;; blank out current neighbourhood
    (save-excursion
      (goto-char (point-max))
      (while (not (bobp))
        (backward-char)
        (while (eq (get-text-property (point) 'face) 'highlight)
          (let ((row (get-text-property (point) 'row))
                (col (get-text-property (point) 'col)))
            (delete-char 1)
            (insert bubbles-empty-char)
            (add-text-properties (1- (point)) (point) (list 'removed t
                                                            'row row
                                                            'col col))))))
    ;; show new score
    (bubbles--update-score)
    ;; update display and wait
    (sit-for 0.5)
    ;; drop down
    (let ((something-dropped nil))
      (save-excursion
        (let ((i 0))
          (while (< i bubbles-grid-height)
            (let ((j 0))
              (while (< j bubbles-grid-width)
                (bubbles--goto i j)
                (while (get-text-property (point) 'removed)
                  (setq something-dropped (or (bubbles--shift 'top i j)
                                              something-dropped)))
                (setq j (1+ j))))
            (setq i (1+ i)))))
      ;; update display and wait
      (if something-dropped
          (sit-for 0.5)))
    ;; shift to right
    (put-text-property (point-min) (point-max) 'removed nil)
    (save-excursion
      (goto-char (point-min))
      (while (not (eobp))
        (if (eq (char-after (point)) bubbles-empty-char)
            (put-text-property (point) (1+ (point)) 'removed t))
        (forward-char 1)))
    (cond ((eq bubbles-shift-mode 'shifter)
           (save-excursion
              (let ((i (1- bubbles-grid-height)))
                (while (>= i 0)
                  (let ((j (1- bubbles-grid-width)))
                    (while (>= j 0)
                      (bubbles--goto i j)
                      (while (get-text-property (point) 'removed)
                        (bubbles--shift 'left i j))
                      (setq j (1- j))))
                  (setq i (1- i))))))
          (t;; default shift-mode
           (save-excursion
             (let ((j (1- bubbles-grid-width)))
               (while (>= j 0)
                 (bubbles--goto (1- bubbles-grid-height) j)
                 (let ((shifted-cols 0))
                   (while (get-text-property (point) 'removed)
                     (setq shifted-cols (1+ shifted-cols))
                     (bubbles--shift 'left (1- bubbles-grid-height) j))
                   (let ((k 0))
                     (while (< k shifted-cols)
                       (let ((i (- bubbles-grid-height 2)))
                         (while (>= i 0)
                           (bubbles--shift 'left i j)
                           (setq i (1- i))))
                       (setq k (1+ k))))
                   (setq j (1- j))))))))
    (put-text-property (point-min) (point-max) 'removed nil)
    (unless (bubbles--neighbourhood-available)
      (bubbles--game-over))))
  
(defun bubbles--shift (from row col)
  "Move bubbles FROM one side to position ROW COL.
Return t if new char is non-empty."
  (save-excursion
    (when (bubbles--goto row col)
      (let ((char-org (char-after (point)))
            (char-new bubbles-empty-char)
            (face-new 'default)
            (removed nil)
            (trow row)
            (tcol col))
        (cond ((eq from 'top)
               (setq trow (1- row)))
              ((eq from 'left)
               (setq tcol (1- col))))
        (save-excursion
          (when (bubbles--goto trow tcol)
            (setq char-new (char-after (point)))
            (setq removed (get-text-property (point) 'removed))
            (bubbles--shift from trow tcol)))
        (insert char-new)
        (delete-char 1)
        (add-text-properties (1- (point)) (point) (list 'row row 'col col
                                                        'face 'default
                                                        'removed removed))
        (not (eq char-new bubbles-empty-char))))))
  
(provide 'bubbles)
;;; bubbles.el ends here



reply via email to

[Prev in Thread] Current Thread [Next in Thread]