X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Flily-library.scm;h=254fb397d9ec91229351b2d45a1b85c909954c41;hb=9a612113da7ca7da2f094ca918c0a21d5ed192f6;hp=eebc231ac574b572c05a8b04a676cf10c3c46822;hpb=1bcc3a3e8bd097f4d9bb99337ac488648fcfbc8a;p=lilypond.git

diff --git a/scm/lily-library.scm b/scm/lily-library.scm
index eebc231ac5..254fb397d9 100644
--- a/scm/lily-library.scm
+++ b/scm/lily-library.scm
@@ -66,6 +66,15 @@
   (or (equal? a b)
       (ly:moment<? a b)))
 
+(define-public (fraction->moment fraction)
+  (if (null? fraction)
+      ZERO-MOMENT
+      (ly:make-moment (car fraction) (cdr fraction))))
+
+(define-public (moment->fraction moment)
+  (cons (ly:moment-main-numerator moment)
+        (ly:moment-main-denominator moment)))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; arithmetic
 (define-public (average x . lst)
@@ -280,6 +289,36 @@ bookoutput function"
 	    (cons (cdar alist)
 		  (flatten-alist (cdr alist))))))
 
+(define (assoc-remove key alist)
+  "Remove key (and its corresponding value) from an alist.
+   Different than assoc-remove! because it is non-destructive."
+  (define (assoc-crawler key l r)
+    (if (null? r)
+        l
+        (if (equal? (caar r) key)
+            (append l (cdr r))
+            (assoc-crawler key (append l `(,(car r))) (cdr r)))))
+  (assoc-crawler key '() alist))
+
+(define-public (map-selected-alist-keys function keys alist)
+  "Returns alist with function applied to all of the values in list keys.
+   For example:
+   @code{guile> (map-selected-alist-keys - '(a b) '((a . 1) (b . -2) (c . 3) (d . 4)))}
+   @code{((a . -1) (b . 2) (c . 3) (d . 4))}"
+   (define (map-selected-alist-keys-helper function key alist)
+     (map
+     (lambda (pair)
+       (if (equal? key (car pair))
+           (cons key (function (cdr pair)))
+           pair))
+     alist))
+   (if (null? keys)
+       alist
+       (map-selected-alist-keys
+         function
+         (cdr keys)
+         (map-selected-alist-keys-helper function (car keys) alist))))
+
 ;;;;;;;;;;;;;;;;
 ;; vector
 
@@ -369,7 +408,7 @@ bookoutput function"
    (lambda (x) x)
    (map proc lst)))
 
-(define (flatten-list x)
+(define-public (flatten-list x)
   "Unnest list."
   (cond ((null? x) '())
         ((not (pair? x)) (list x))
@@ -435,17 +474,6 @@ bookoutput function"
       (cons (cons (car coords) (cadr coords))
 	    (ly:list->offsets accum (cddr coords)))))
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; numbers
-
-(if (not (defined? 'nan?)) ;; guile 1.6 compat
-    (define-public (nan? x) (not (or (< 0.0 x)
-				     (> 0.0 x)
-				     (= 0.0 x)))))
-
-(if (not (defined? 'inf?))
-    (define-public (inf? x) (= (/ 1.0 x) 0.0)))
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; intervals
 
@@ -482,27 +510,25 @@ bookoutput function"
 
 (define-public interval-end cdr)
 
-(define-public (interval-translate iv amount)
-  (cons (+ amount (car iv))
-	(+ amount (cdr iv))))
-
 (define (other-axis a)
   (remainder (+ a 1) 2))
 
 (define-public (interval-widen iv amount)
-   (cons (- (car iv) amount)
-         (+ (cdr iv) amount)))
+  (cons (- (car iv) amount)
+    (+ (cdr iv) amount)))
 
 (define-public (interval-empty? iv)
    (> (car iv) (cdr iv)))
 
 (define-public (interval-union i1 i2)
-   (cons (min (car i1) (car i2))
-	 (max (cdr i1) (cdr i2))))
+  (cons
+    (min (car i1) (car i2))
+    (max (cdr i1) (cdr i2))))
 
 (define-public (interval-intersection i1 i2)
-   (cons (max (car i1) (car i2))
-	 (min (cdr i1) (cdr i2))))
+   (cons
+     (max (car i1) (car i2))
+     (min (cdr i1) (cdr i2))))
 
 (define-public (interval-sane? i)
   (not (or  (nan? (car i))
@@ -515,6 +541,104 @@ bookoutput function"
   (cons (min (interval-start interval) p)
         (max (interval-end interval) p)))
 
+(define-public (reverse-interval iv)
+  (cons (cdr iv) (car iv)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; coordinates
+
+(define coord-x car)
+(define coord-y cdr)
+
+(define (coord-operation operator operand coordinate)
+  (if (pair? operand)
+    (cons (operator (coord-x operand) (coord-x coordinate))
+          (operator (coord-y operand) (coord-y coordinate)))
+    (cons (operator operand (coord-x coordinate))
+          (operator operand (coord-y coordinate)))))
+
+(define (coord-apply function coordinate)
+  (if (pair? function)
+    (cons
+      ((coord-x function) (coord-x coordinate))
+      ((coord-y function) (coord-y coordinate)))
+    (cons
+      (function (coord-x coordinate))
+      (function (coord-y coordinate)))))
+
+(define-public (coord-translate coordinate amount)
+  (coord-operation + amount coordinate))
+
+(define-public (coord-scale coordinate amount)
+  (coord-operation * amount coordinate))
+
+(define-public (coord-rotate coordinate degrees-in-radians)
+  (let*
+    ((coordinate
+      (cons
+        (exact->inexact (coord-x coordinate))
+        (exact->inexact (coord-y coordinate))))
+     (radius
+      (sqrt
+        (+ (* (coord-x coordinate) (coord-x coordinate))
+           (* (coord-y coordinate) (coord-y coordinate)))))
+    (angle (angle-0-2pi (atan (coord-y coordinate) (coord-x coordinate)))))
+   (cons
+     (* radius (cos (+ angle degrees-in-radians)))
+     (* radius (sin (+ angle degrees-in-radians))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; trig
+
+(define-public PI (* 4 (atan 1)))
+
+(define-public TWO-PI (* 2 PI))
+
+(define-public PI-OVER-TWO (/ PI 2))
+
+(define-public THREE-PI-OVER-TWO (* 3 PI-OVER-TWO))
+
+(define-public (cyclic-base-value value cycle)
+  "Takes a value and modulo-maps it between 0 and base."
+  (if (< value 0)
+      (cyclic-base-value (+ value cycle) cycle)
+      (if (>= value cycle)
+          (cyclic-base-value (- value cycle) cycle)
+          value)))
+
+(define-public (angle-0-2pi angle)
+  "Takes an angle in radians and maps it between 0 and 2pi."
+  (cyclic-base-value angle TWO-PI))
+
+(define-public (angle-0-360 angle)
+  "Takes an angle in radians and maps it between 0 and 2pi."
+  (cyclic-base-value angle 360.0))
+
+(define-public PI-OVER-180  (/ PI 180))
+
+(define-public (degrees->radians angle-degrees)
+  "Convert the given angle from degrees to radians"
+  (* angle-degrees PI-OVER-180))
+
+(define-public (ellipse-radius x-radius y-radius angle)
+  (/
+    (* x-radius y-radius)
+    (sqrt
+      (+ (* (expt y-radius 2)
+            (* (cos angle) (cos angle)))
+        (* (expt x-radius 2)
+           (* (sin angle) (sin angle)))))))
+
+(define-public (polar->rectangular radius angle-in-degrees)
+  "Convert polar coordinate @code{radius} and @code{angle-in-degrees}
+   to (x-length . y-length)"
+  (let ((complex (make-polar
+                    radius
+                    (degrees->radians angle-in-degrees))))
+     (cons
+       (real-part complex)
+       (imag-part complex))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; string
 
@@ -637,6 +761,9 @@ applied to function @var{getter}.")
 (define-public (car< a b)
   (< (car a) (car b)))
 
+(define-public (car<= a b)
+  (<= (car a) (car b)))
+
 (define-public (symbol<? lst r)
   (string<? (symbol->string lst) (symbol->string r)))
 
@@ -698,14 +825,8 @@ applied to function @var{getter}.")
 
 ;;; FONT may be font smob, or pango font string...
 (define-public (font-name-style font)
-  ;; FIXME: ughr, barf: feta-alphabet is actually emmentaler
-  (if (and (string? font)
-	   (string-prefix? "feta-alphabet" font))
-      (string-append "emmentaler"
-		     "-"
-		     (substring font
-				(string-length "feta-alphabet")
-				(string-length font)))
+  (if (string? font)
+      (string-downcase font)
       (let* ((font-name (ly:font-name font))
 	     (full-name (if font-name font-name (ly:font-file-name font))))
 	  (string-downcase full-name))))