#! /bin/sh
# -*- mode: scheme; coding: utf-8 -*-
exec guile -e main -s "$0" "$@"
!#


;;;;
;;;; Copyright (C) 2022 - 2023
;;;; Free Software Foundation, Inc.

;;;; This file is part of GNU G-Golf

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

;;;; GNU G-Golf 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
;;;; Lesser General Public License for more details.

;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with GNU G-Golf.  If not, see
;;;; <https://www.gnu.org/licenses/lgpl.html>.
;;;;

;;; Commentary:

;;; Code:


(eval-when (expand load eval)
  (use-modules (oop goops))

  (default-duplicate-binding-handler
    '(merge-generics replace warn-override-core warn last))

  (use-modules (g-golf))

  (g-irepository-require "Gtk" #:version "4.0")
  (for-each (lambda (name)
              (gi-import-by-name "Gdk" name))
      '("ContentProvider"
        "Paintable"
        "DragAction"))

  (for-each (lambda (name)
              (gi-import-by-name "Gtk" name))
      '("Application"
        "ApplicationWindow"
        "HeaderBar"
        "CssProvider"
        "Grid"
        "Button"
        "Image"
        "DragSource"
        "DropTarget"
        "MediaStream"
        "MediaFile"
        "get_major_version"
        "get_minor_version"
        "get_micro_version")))


(define-class <solitaire-peg> (<gobject> <gdk-paintable>)
  (column #:accessor !column #:init-keyword #:column)
  (row #:accessor !row #:init-keyword #:row))

(define-vfunc (get-flags-vfunc (self <solitaire-peg>))
  '(size contents))

(define-vfunc (get-intrinsic-width-vfunc (self <solitaire-peg>))
  32)

(define-vfunc (get-intrinsic-height-vfunc (self <solitaire-peg>))
  32)

(define-vfunc (snapshot-vfunc (self <solitaire-peg>) snapshot width height)
  (receive (outline outline:bounds)
      (allocate-c-struct gsk-rounded-rect bounds)
    (gsk-rounded-rect-init-from-rect outline
                                     (graphene-rect-init (graphene-rect-alloc)
                                                         0 0  width height)
                                     3.5) ;; px - approx. 0.3em [default fontsize]
      (push-rounded-clip snapshot outline)
      (append-color snapshot
                    '(0.61 0.1 0.47 1.0) ;; vocaloid
                    outline:bounds)
      ;; pop is a guile scheme syntax, hence its name is protected, See
      ;; the 'Customization Square', 'GI Syntax Name Protect' section of
      ;; the G-Golf manual for more on this subject.
      (pop_ snapshot)))


;;;
;;; DND - Drag aNd Drop
;;;

;; The peg-solitaire.c example uses [g-object-]set-data and
;; [g-object-]get-data to cache the peg that is being dragged, which is
;; required, to be able to restore the game in its previous state,
;; should a drag be ended prior reaching a valid drop target.

;; We could also use the GObject [set|get]-data, but there is bug in the
;; GI definition for g_object_get_data: its return-type tag is void,
;; although it returns a gpointer. When the return-type of a function or
;; a method is void, G-Golf does not even try to look at the callable
;; gi-argument result - it finalizes the function or method execution by
;; calling (values).

;; Even if it did work though, GObject [set|get]-data are provided as a
;; convinient data storage mini system for C programmers. We can cache
;; our own things in pure scheme code of course - actually, in G-Golf,
;; we stow, using the yet to be documented stow-set! KEY VALUE and
;; stow-ref KEY - and that is what we are going to do.

(define (drag-prepare source x y)
  (let* ((image (get-widget source))
         (peg (get-paintable image)))
    (and peg
         (let* ((g-type (!g-type <solitaire-peg>))
                (g-value (g-value-init g-type)))
           (g-value-set! g-value (!g-inst peg))
           (gdk-content-provider-new-for-value g-value)))))

(define (drag-begin source drag)
  (let* ((image (get-widget source))
         (peg (get-paintable image)))
    (set-icon source peg -2 -2)
    (stow-set! 'drag-begin peg)
    (clear image)))

(define (drag-end source drag delete-data)
  ;; When delete-data is #t, the drag was successful and we should now
  ;; delete the peg (from the peg's origin image), but we took care of
  ;; that in the drag-begin callback already, so there's no need to do
  ;; anything anymore.
  (unless delete-data
    (let ((image (get-widget source))
          (peg (stow-ref 'drag-begin)))
      (set-from-paintable image peg))))

(define (drop-accept target drop)
  (let* ((image (get-widget target))
         (content-formats (get-formats drop))
         (drop-peg?
          (gdk-content-formats-contain-gtype content-formats
                                             (!g-type <solitaire-peg>))))
    (if (or (not drop-peg?) ;; it has to be a peg
            (get-paintable image)) ;; target must not already have a peg
        #f #t)))

(define (drop-drop target peg x y)
  (let* ((image (get-widget target))
         (grid (get-parent image))
         (peg-column (!column peg))
         (peg-row (!row peg)))
    (receive (image-column image-row width height)
        (query-child grid image)
      (if (not (or (and (= (abs (- image-column peg-column)) 2)
                        (= image-row peg-row))
                   (and (= (abs (- image-row peg-row)) 2)
                        (= image-column peg-column))))
          #f ;; not a valid jump
          (let ((jumped (get-child-at grid
                                      (/ (+ image-column peg-column) 2)
                                      (/ (+ image-row peg-row) 2))))
            (if (not (get-paintable jumped))
                #f ;; jump over an empty image
                (begin
                  (clear jumped)
                  (mslot-set! peg
                              'column image-column
                              'row image-row)
                  (set-from-paintable image peg)
                  (check-for-end grid)
                  #t))))))) ;; valid jump

(define (check-for-end grid)
  (let ((n-peg 0)
        (n-move 0))
    (do ((i 0
            (+ i 1)))
        ((or (= i 7)
             (and (> n-peg 1) (> n-move 0))))
      (do ((j 0
              (+ j 1)))
          ((or (= j 7)
               (and (> n-peg 1) (> n-move 0))))
        (let ((image (get-child-at grid i j)))
          (when (and image
                     (get-paintable image))
            (set! n-peg (+ n-peg 1))
            (set! n-move (count-moves grid i j))))))
    (if (and (= n-peg 1)
             (get-paintable (get-child-at grid 3 3)))
        (celebrate #t)
        (if (= n-move 0)
            (celebrate #f)))))

(define (count-moves grid i j)
  (count identity
         (map (lambda (item)
                (apply check-move item))
           `((,grid ,i ,j 1 0)
             (,grid ,i ,j -1 0)
             (,grid ,i ,j 0 1)
             (,grid ,i ,j 0 -1)))))

(define (check-move grid i j di dj)
  ;; We have a peg at i j.
  ;; Check if we can move the peg to i + 2*di, j + 2*dj
  (let ((image (get-child-at grid (+ i di) (+ j dj))))
    (if (or (not image)
            (not (get-paintable image)))
        #f
        (let ((image (get-child-at grid (+ i (* di 2)) (+ j (* dj 2)))))
          (if (or (not image)
                  (get-paintable image))
              #f
              #t)))))

(define (celebrate win?)
  (let* ((sounds-dir "/usr/share/sounds/freedesktop/stereo/")
         (sound (if win?
                    (string-append sounds-dir "complete.oga")
                    (string-append sounds-dir "dialog-error.oga")))
         (g-file (g-file-new-for-path sound))
         (stream (gtk-media-file-new-for-file g-file)))
    (unref g-file)
    (set-volume stream 1.0)
    (play stream)

    (connect stream
             'notify::ended
             (lambda (g-object property)
               (unref g-object)))))

;;;
;;; Check version
;;;

(define (gtk-check-version major minor micro)
  (let ((gtk-major (gtk-get-major-version))
        (gtk-minor (gtk-get-minor-version))
        (gtk-micro (gtk-get-micro-version)))
    (or (> gtk-major major)
        (and (= gtk-major major)
             (> gtk-minor minor))
        (and (= gtk-major major)
             (= gtk-minor minor)
             (>= gtk-micro micro)))))


;;;
;;; The game board
;;;

(define %css-data
  ".solitaire-field {
    border: 1px solid lightgray;
    /* border: 3px solid #d4cbb6; texinfo code border */
    /* border: 3px solid #495106; tango trash outline */
    border-radius: 3.5px; /* approx. 0.3em [default fontsize] */
    /* padding: 2px; */
}")

(define (create-board window)
  (let* ((grid (make <gtk-grid>
                 #:margin-top 24
                 #:margin-start 24
                 #:margin-bottom 24
                 #:margin-end 24
                 #:halign 'center
                 #:valign 'center
                 #:column-spacing 6
                 #:column-homogeneous #t
                 #:row-spacing 6
                 #:row-homogeneous #t))
         (css-provider (let ((provider (make <gtk-css-provider>)))
                         (cond ((gtk-check-version 4 10 0)
                                (gtk-css-provider-load-from-data provider
                                                                 %css-data
                                                                 (string-length %css-data)))
                               (else
                                (gtk-css-provider-load-from-data provider %css-data)))
                         provider)))
    (set-child window grid)
    (do ((i 0
            (+ i 1)))
        ((= i 7))
      (do ((j 0
              (+ j 1)))
          ((= j 7))
        (unless (and (or (< i 2) (>= i 5))
                     (or (< j 2) (>= j 5)))
          (let ((image (make <gtk-image>
                         #:icon-size 'large
                         #:overflow 'hidden))
                (source (make <gtk-drag-source> #:actions '(move)))
                (target (gtk-drop-target-new (!g-type <solitaire-peg>) '(move))))
            (add-provider (get-style-context image) css-provider 800)
            (add-css-class image "solitaire-field")
            (unless (and (= i 3) (= j 3))
              (set-from-paintable image
                                  (make <solitaire-peg> #:column j #:row i)))
            (attach grid image j i 1 1)
            (connect source 'prepare drag-prepare)
            (connect source 'drag-begin drag-begin)
            (connect source 'drag-end drag-end)
            (add-controller image source)
            (connect target 'accept drop-accept)
            (connect target 'drop drop-drop)
            (add-controller image target)))))
    (unref css-provider)))

(define (restart-game window)
  (stow-reset!)
  (create-board window))


(define (activate app)
  (let ((window (make <gtk-application-window>
                  #:title "Peg Solitaire"
                  #:default-width 420
                  #:default-height 420
                  #:application app))
        (header-bar (make <gtk-header-bar>))
        (restart (make <gtk-button>
                   #:icon-name "view-refresh-symbolic")))

    (connect restart
             'clicked
             (lambda (bt)
               (restart-game window)))

    (set-titlebar window header-bar)
    (pack-start header-bar restart)
    (create-board window)
    (present window)))


(define (main args)
  (letrec ((debug? (or (member "-d" args)
                       (member "--debug" args)))
           (animate
            (lambda ()
              (let ((app (make <gtk-application>
                           #:application-id "org.gnu.g-golf.peg-solitaire")))
                (connect app 'activate activate)
                (let ((status (run app '())))
                  (exit status))))))
    (if debug?
        (parameterize ((%debug #t))
          (animate))
        (animate))))
