Can now move/resize windows with the mouse.

When doing so, the window is automatically floated.

Closes #4

lib/gram/lib/drag.scm

@@ -0,0 +1,96 @@
(define-module (gram lib drag)
  #:export (drag-move-view drag-resize-view drag-stop-acting drag-setup)
  #:use-module (srfi srfi-11)
  #:use-module (ice-9 match)
  #:use-module (gram pointer)
  #:use-module (gram pointer hooks)
  #:use-module (gram keysym hooks)
  #:use-module (gram keysym)
  #:use-module (gram lib keymap)
  #:use-module (gram lib render-hooks)
  #:use-module (gram lib zipper)
  #:use-module ((gram view) #:renamer (symbol-prefix-proc 'view-)))

;;; starting position for a drag. Can't drag multiple at once, but I
;;; can't imagine how you would manage that.
(define %origin #f)
;;; original geometry
(define %origin-geometry #f)
;;; action taking place, either do-move or do-resize
(define %action #f)
;;; view being acted on
(define %action-target #f)

(define (acting?)
  "Returns #t if the user is currently acting on (moving or resizing)
a view."
  (and %origin %origin-geometry %action %action-target))

(define (drag-stop-acting)
  "Stops the interaction. Only one interaction can occur at a time."
  (set! %origin #f)
  (set! %origin-geometry #f)
  (set! %action #f)
  (set! %action-target #f))

(define (distance-moved origin position)
  (values
   (- (car position) (car origin))
   (- (cdr position) (cdr origin))))

(define (on-move _ position)
  (when (acting?)
    (%action position)))

(define (do-move! position)
  (when (acting?)
    (let-values ([(dx dy) (distance-moved %origin position)])
      (match %origin-geometry
        [((x . y) . dims)
         (view-set-geometry %action-target (cons
                                            (cons (+ x dx) (+ y dy))
                                            dims))]
        [_ (error "Invalid origin geometry ~a" %origin-geometry)]))))

(define (do-resize! position)
  (when (acting?)
    (let-values ([(dx dy) (distance-moved %origin position)])
      (match %origin-geometry
        [(pos w . h)
         (view-set-geometry %action-target (cons
                                            pos
                                            (cons (+ w dx) (+ h dy))))]
        [_ (error "Invalid origin geometry ~a" %origin-geometry)]))))

(define-syntax-rule (define-interaction name act docstring)
  (define (name view)
    docstring
    (unless (acting?)
      (let ((eq (lambda (x) (equal? view x))))
        (transform-workspace! 'tiling (lambda (z)
                                        (transform z eq del)))
        (transform-workspace! 'floating (lambda (z)
                                          (if (find z eq)
                                              z
                                              (or (add-view z view) z)))))
      (re-render!)
      (set! %origin (pointer-position))
      (set! %origin-geometry (view-get-geometry view))
      (set! %action act)
      (set! %action-target view))))

(define-interaction drag-move-view do-move!
  "Begin moving the given view with the given position as the origin.")
(define-interaction drag-resize-view do-resize!
  "Begin resizing the given view with the given position as the origin.")

(define (drag-setup km interaction key)
  "Set up the given interaction to begin when `key' is pressed and end
when the unmodified `key' is released."
  (define-key! km key interaction)
  (add-hook! keyup-hook (lambda (released view)
                          (let ((rel (unmodified released)))
                            (when (equal? rel (unmodified key))
                              (drag-stop-acting)))))
  (unless (member on-move (hook->list pointer-motion-hook))
    (add-hook! pointer-motion-hook on-move)))

lib/gram/lib/render-hooks.scm

@@ -10,7 +10,7 @@
  #:use-module (gram view hooks)
  #:use-module ((gram output) #:renamer (symbol-prefix-proc 'output-))
  #:use-module (gram output hooks)
  #:export (transform-workspace! transform-layout! current-view))
  #:export (transform-workspace! transform-layout! current-view add-view re-render!))

(define %default-layout (tall))
(define %default-floating-layout (simple))
@@ -151,7 +151,8 @@ created."
(define (view-destroyed)
  (transform-workspace! 'both (lambda (z) (zfilter z view-active?)))
  (when (current-view)
      (view-focus (current-view))))
      (view-focus (current-view)))
  (re-render!))

(define (view-handle-geometry view geo)
  (format #t "View ~a requested geometry ~a\n" view geo))

scripts/init.scm

@@ -11,7 +11,8 @@
             (gram lib zipper)
             (gram lib motion)
             (gram lib render-hooks)
             (gram lib keymap))
             (gram lib keymap)
             (gram lib drag))

(spawn-server)

@@ -25,7 +26,7 @@
  (open-input-output-pipe cmd))


(add-hook! keydown-hook (keymap-hook 'default-keymap))
(add-hook! keydown-hook (keymap-hook default-keymap))

(define-key! default-keymap (kbd "M-x") (cute run "dmenu_run"))
(define-key! default-keymap (kbd "M-<Space>") (cute run "st"))
@@ -35,3 +36,6 @@
(define-key! default-keymap (kbd "C-M-n") (cute move-window 'right))
(define-key! default-keymap (kbd "C-M-e") (cute move-window 'left))
(define-key! default-keymap (kbd "Mouse1") view-focus)

(drag-setup default-keymap drag-move-view (kbd "M-Mouse1"))
(drag-setup default-keymap drag-resize-view (kbd "M-Mouse2"))

src/hooks/hooks.c

@@ -38,6 +38,13 @@ init_gram_pointer_hooks (void *ignore)
  gram_pointer_motion_hook_init ();
}

static void
init_gram_pointer (void *ignore)
{
  /* defined in pointer_motion.h */
  gram_pointer_fns_init();
}

static void
init_gram_compositor_hooks (void *ignore)
{
@@ -54,4 +61,8 @@ init_gram_hooks (void)
  scm_c_define_module ("gram pointer hooks", init_gram_pointer_hooks, NULL);
  scm_c_define_module ("gram compositor hooks", init_gram_compositor_hooks,
                       NULL);
  /* this is out of place but I don't have a better spot for it right
   * now. */

  scm_c_define_module ("gram pointer", init_gram_pointer, NULL);
}

src/hooks/pointer_motion.c

@@ -28,3 +28,20 @@ gram_pointer_motion_hook_run (void *data)
                                        scm_from_uint32 (input->point->y))));
  return SCM_UNSPECIFIED;
}

SCM
gram_pointer_position (void)
{
  struct wlc_point pos;
  wlc_pointer_get_position(&pos);

  return scm_cons(scm_from_uint32(pos.x),
                  scm_from_uint32(pos.y));
}

void gram_pointer_fns_init (void)
{
  scm_c_define_gsubr("pointer-position", 0, 0, 0, gram_pointer_position);

  scm_c_export("pointer-position", NULL);
}

src/hooks/pointer_motion.h

@@ -11,3 +11,7 @@ struct pointer_motion_input

void gram_pointer_motion_hook_init (void);
void *gram_pointer_motion_hook_run (void *data);

/* TODO: move this to its own file. Leaving it here for now because I
 * don't want to add all that infrastructure for a single function. */
void gram_pointer_fns_init (void);

src/types/keysym.c

@@ -155,13 +155,29 @@ gram_key_swallow_next (void)
  return SCM_BOOL_T;
}

SCM
gram_keysym_unmodified (SCM keysym_smob)
{
  scm_assert_smob_type(gram_keysym_tag, keysym_smob);
  struct gram_keysym *keysym =
    (struct gram_keysym *) SCM_SMOB_DATA (keysym_smob);
  struct gram_keysym copy;      /* copying just to guarantee that I
                                 * don't corrupt the original */
  memcpy(&copy,keysym, sizeof(struct gram_keysym));

  copy.mods.mods = 0;

  return gram_keysym_scm(&copy);
}

void
init_gram_keysym_fns (void *data)
{
  scm_c_define_gsubr ("swallow-next-key", 0, 0, 0, gram_key_swallow_next);
  scm_c_define_gsubr ("kbd", 1, 0, 0, gram_keysym_construct);
  scm_c_define_gsubr ("unmodified", 1, 0, 0, gram_keysym_unmodified);

  scm_c_export ("swallow-next-key", "kbd", NULL);
  scm_c_export ("swallow-next-key", "kbd", "unmodified", NULL);
}

void

src/types/view.c

@@ -170,21 +170,21 @@ SCM
gram_geometry_scm (const struct wlc_geometry * geo)
{
  /* can't make records from c and a new smob for this is really overkill */
  return scm_cons (scm_cons (scm_from_uint32 (geo->origin.x),
                             scm_from_uint32 (geo->origin.y)),
                   scm_cons (scm_from_uint32 (geo->size.w),
                             scm_from_uint32 (geo->size.h)));
  return scm_cons (scm_cons (scm_from_int32 (geo->origin.x),
                             scm_from_int32 (geo->origin.y)),
                   scm_cons (scm_from_int32 (geo->size.w),
                             scm_from_int32 (geo->size.h)));
}

/* converts an SCM to a wlc_geometry. Assumes input is valid. */
static const struct wlc_geometry
gram_geometry_from_scm (SCM _geo)
{
  struct wlc_geometry geo = {
    {scm_to_uint32 (scm_caar (_geo)),
     scm_to_uint32 (scm_cdar (_geo))},
    {scm_to_uint32 (scm_cadr (_geo)),
     scm_to_uint32 (scm_cddr (_geo))}
    {scm_to_int32 (scm_caar (_geo)),
     scm_to_int32 (scm_cdar (_geo))},
    {scm_to_int32 (scm_cadr (_geo)),
     scm_to_int32 (scm_cddr (_geo))}
  };

  return geo;

test/types/keysym_spec.c

@@ -385,12 +385,48 @@ START_TEST (test_keysym_swallow)
  ck_assert_ptr_eq (res, SCM_BOOL_T);
}

END_TEST Suite *
END_TEST

START_TEST (test_keysym_unmodified)
{
  scm_init_guile ();
  init_gram_keysym ();

  scm_c_use_module ("gram keysym");

  struct gram_keysym ks = {
    .keycode = XKB_KEY_x,
    .sym = XKB_KEY_x,
    .mods = {
             .leds = 0,
             .mods = WLC_BIT_MOD_ALT,
    },
    .mouse = false,
    .mouse_button = -1
  };

  SCM res = scm_call_1 (scm_variable_ref (scm_c_lookup ("unmodified")),
                        gram_keysym_scm(&ks));

  scm_assert_smob_type(gram_keysym_tag, res);
  struct gram_keysym *unmod = (struct gram_keysym*) SCM_SMOB_DATA(res);
  /* it should reset mods */
  ck_assert_uint_eq(unmod->mods.mods, 0);
  /* it shouldn't change anything else */
  ck_assert_uint_eq(unmod->mods.leds, ks.mods.leds);
  ck_assert_uint_eq(unmod->sym, ks.sym);
  ck_assert_uint_eq(unmod->keycode, ks.keycode);
  ck_assert_uint_eq(unmod->mouse, ks.mouse);
  ck_assert_uint_eq(unmod->mouse_button, ks.mouse_button);
}
END_TEST

Suite *

keysym_suite (void)
{
  Suite *s;
  TCase *tc_core, *tc_convert, *tc_equalp, *tc_display, *tc_swallow;
  TCase *tc_core, *tc_convert, *tc_equalp, *tc_display, *tc_swallow, *tc_unmod;

  s = suite_create ("types/keysym");

@@ -425,6 +461,10 @@ keysym_suite (void)
  tcase_add_test (tc_swallow, test_keysym_swallow);
  suite_add_tcase (s, tc_swallow);

  tc_unmod = tcase_create("unmodified");
  tcase_add_test (tc_unmod, test_keysym_unmodified);
  suite_add_tcase (s, tc_unmod);

  return s;
}