Merge branch 'master' of ssh://rshann@git.sv.gnu.org/srv/git/denemo

2 files changed, 185 insertions, 36 deletions

diff --git a/actions/ans.scm b/actions/ans.scm
index d9fabcd8..3b8bee7f 100644
--- a/actions/ans.scm
+++ b/actions/ans.scm
@@ -888,7 +888,7 @@
 	(d-MoveCursorLeft)
 	(ANS::ChangeChordNotes ansNotes)
 	(if duration  ;If user gave duration parameter. Does not test if the duration is a valid number
-			(eval-string (string-append "(d-Change" (number->string duration) ")"))) ; TODO: eval string should be gone. And it does not support breve and longa!
+			(eval-string (string-append "(d-Change" (number->string duration) ")"))) 
 	(if (and dots (not (= dots 0))) ;If the user gave 0 as durations ignore that as well
 			(let loop ((count 0)) 
 				(d-AddDot)
@@ -918,6 +918,49 @@
  	; +20 from "...eses" to plain.
  	(+ 20 (* 50 (quotient ansNote 50))))
 
+;without enharmonic or chromatic versions. This functions simply is concerned about how it "sounds".
+;Returns the half-tone step distance from C. 
+(define (ANS::GetHalfToneDistanceFromC ansNote)
+		(if (= ansNote +inf.0)
+			+inf.0
+			(case (remainder ansNote 350)
+				((00) 10) ; ceses,,, -> bes
+				((10) 11) ; ces,,, -> b
+				((20) 0) ; c,,, 
+				((30) 1) ; cis,,,
+				((40) 2) ; cisis,,, -> d ...
+				((50) 0) ; deses,,,
+				((60) 1) ; des,,,
+				((70) 2) ; d,,,
+				((80) 3) ; dis,,,
+				((90) 4) ; disis,,,
+				((100) 2) ; eeses,,,
+				((110) 3) ; ees,,,
+				((120) 4) ; e,,,
+				((130) 5) ; eis,,,
+				((140) 6) ; eisis,,,
+				((150) 3) ; feses,,,
+				((160) 4) ; fes,,,
+				((170) 5) ; f,,,
+				((180) 6) ; fis,,,
+				((190) 7) ; fisis,,,
+				((200) 5) ; geses,,,
+				((210) 6) ; ges,,,
+				((220) 7) ; g,,,
+				((230) 8) ; gis,,,
+				((240) 9) ; gisis,,,
+				((250) 7) ; aeses,,,
+				((260) 8) ; aes,,,
+				((270) 9) ; a,,,
+				((280) 10) ; ais,,,
+				((290) 11) ; aisis,,,
+				((300) 9) ; beses,,,
+				((310) 10) ; bes,,,
+				((320) 11) ; b,,,
+				((330) 0) ; bis,,,
+				((340) 1) ; bisis,,,
+				(else #f))))
+
 ;Alteration adds a sharp, flat or nothing to a ans-note. Returns an ANS
 ;number. Wants an ans number and a procedure that will return either 0, 1 or -1. 
 (define (ANS::Alteration ansNote modificator)
@@ -988,9 +1031,11 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;Analaysis;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-;Convert two ANS notes to one ANS interval
+;Convert two ANS notes to one ANS interval, ignores octaves.
+;TODO: Give out the octave between.
 ;Return pair in pair: (intervall (lower . higher))
-(define	(ANS::GetIntervall ansNoteOne ansNoteTwo)
+;Yes, I made a typo in Intervall. 
+(define (ANS::GetIntervall ansNoteOne ansNoteTwo)
 	(define higher ansNoteOne)
 	(define lower ansNoteTwo)
 	(if (<= ansNoteOne ansNoteTwo) ; bring the notes in right order. We want to calculate from top to bottom.
@@ -1000,15 +1045,101 @@
 	;Extract the tone, without octave and feed it to the hash to get the notes position in the pillar of 5th.
 	(cons
 		(- (hashq-ref ANS::PillarOfFifthIndex (ANS::GetNote higher)) (hashq-ref ANS::PillarOfFifthIndex (ANS::GetNote lower)))
-		(cons ansNoteTwo ansNoteOne))) ; do NOT return the ordered invervals. Return as they came in.
+		(cons ansNoteTwo ansNoteOne))) ; do NOT return the ordered or simplified invervals. Return as they came in.
 
 
 ;GetIntervall for lists. 
 ;Converts a list of pairs(lower note and higher ANS note) to a list of interval numbers (ans syntax. steps in the pillar of 5th)
-(define (ANS::CreateIntervalsFromPairs listy) ;Wants a list of pairs.
+;Wants a list of pairs
+(define (ANS::CreateIntervalsFromPairs listy)
 	(define (GetIntv pair)
 		(ANS::GetIntervall (car pair) (cdr pair)))
 	(map GetIntv listy))
+	
+; Wants a number from ANS::GetIntervall 
+; Returns a number which represents the simplest "sounding" interval.
+; For example: c - gis becomes c -as and therefore a minor sixth.  All Tritoni are represented as augmented 4th.
+; There has to be made a decision if the "higher" interval is sounding lower like diminished 1 or double diminished 2. Is C - Ces M7 or m2? For Denemo all intervals are from bottom to top so ces is M7.
+; Augmented Prime and Diminished Octave have to build an Octave; so do have Augmented Octave and Diminished Prime.
+; With the normal system a double diminished second has to be treated as Major Seventh! Or not? Its confusing.
+(define (ANS::Interval->Sound interval)	
+	(case interval
+		((0) 0) ;P1			
+		((-5) -5) ;m2			
+		((2) 2) ;M2			
+		((-3) -3) ;m3
+		((4) 4) ;M3	
+		((-1) -1) ;P4	
+		((6) 6) ;T		
+		((1) 1) ;P5
+		((-4) -4) ;m6			
+		((3) 3) ;M6		
+		((-2) -2) ;m7	
+		((5) 5) ;M7		
+		;Augmentend, Diminished
+		((7) -5) ;A1		
+		((-7) 5) ;D1 ; ALERT
+		((9) -3) ;A2
+		((-12) 0) ;D2
+		((11) -1) ;A3
+		((-10) 2) ;D3
+		((6) 6) ;A4
+		((-8) 4) ;D4
+		((8) -4) ;A5		
+		((-6) 6) ;D5
+		((10) -2) ;A6	
+		((-11) 1) ;D6	
+		((12) 0) ;A7		
+		((-9) 3) ;D7
+		#! ;Double Augmented, Double Diminished
+		((14) ) ;AA1		
+		((-14) ) ;DD1		
+		((16) ) ;AA2		
+		((-19) ) ;DD2			
+		((18) ) ;AA3		
+		((-17) ) ;DD3					
+		((13) ) ;AA4		
+		((-15) ) ;DD4			
+		((15) ) ;AA5		
+		((-13) ) ;DD5
+		((17) ) ;AA6		
+		((-18) ) ;DD6		
+		((19) ) ;AA7		
+		((-16) ) ;DD7
+		;Triple Augmented, Triple Diminished
+		((21) ) ;AAA1		
+		((-21) ) ;DDD1		
+		((23) ) ;AAA2		
+		((-26) ) ;DDD2			
+		((25) ) ;AAA3		
+		((-24) ) ;DDD3					
+		((20) ) ;AAA4		
+		((-22) ) ;DDD4			
+		((22) ) ;AAA5		
+		((-20) ) ;DDD5
+		((24) ) ;AAA6		
+		((-25) ) ;DDD6		
+		((26) ) ;AAA7		
+		((-23) ) ;DDD7
+		;Quadruple Augmented, Quadruple Diminished		
+		((28) ) ;AAAA1		
+		((-28) ) ;DDDD1		
+		((30) ) ;AAAA2		
+		((-33) ) ;DDDD2			
+		((32) ) ;AAAA3		
+		((-31) ) ;DDDD3					
+		((27) ) ;AAAA4		
+		((-29) ) ;DDDD4			
+		((29) ) ;AAAA5		
+		((-27) ) ;DDDD5
+		((31) ) ;AAAA6		
+		((-32) ) ;DDDD6		
+		((33) ) ;AAAA7		
+		((-30) ) ;DDDD7		
+		;Quintuple Augmented, Quintuple Diminished. Only feses to bisis, the Final Frontier.	
+		((34) ) ;AAAAA4		
+		((-34) ) ;DDDDD5 !#
+		(else #f)))
 
 ;ANS::IntervalMember? checks if a forbidden interval is in the given list
 ;;Wants a list of ans intervals, returns #t or #f
diff --git a/actions/denemo.scm b/actions/denemo.scm
index 381a92ec..15486740 100644
--- a/actions/denemo.scm
+++ b/actions/denemo.scm
@@ -61,14 +61,14 @@
 			(loop)
 			#t)))
 			
-;Repeat a function until another (a test) returns #f. The return value of proc does NOT matter
-;;Warning: From all Repeat functions this one has the highest probability to be stuck in a loop forever. Always use tests that MUST return #t in the end. Do NOT use the Denemo tests like (None?) or (Music?) for example, they know nothing about a staffs end.
-(define (RepeatProcUntilTest proc test)
+;Repeat a function while another (a test) returns #t. The return value of proc does NOT matter
+;;Warning: From all Repeat functions this one has the highest probability to be stuck in a loop forever. Always use tests that MUST return #f in the end. Do NOT use the Denemo tests like (None?) or (Music?) for example, they know nothing about a staffs end.
+(define (RepeatProcWhileTest proc test)
 	(RepeatUntilFail 		
 		(lambda () 
 			(if (test)
-				#f ; test true, let RepeatUntilFail fail.
-				(begin (proc) #t))))) ; this is a dumb script. It will try to execute proc again even if proc itself returned #f. 		
+				(begin (proc) #t); this is a dumb script. It will try to execute proc again even if proc itself returned #f. 	
+				#f )))) ; test failed, let RepeatUntilFail fail.		
 
 
 ;;; GetUniquePairs is a function that takes a list and combines each value with any other, but without duplicates and in order.
@@ -150,36 +150,33 @@
 	 (list-ref (reverse (string-tokenize(d-GetNotes))) 0)
 	 #f))
 
-;Next Selected Object for all Staffs by Nils Gey Feb/2010
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;Moves the cursor to the right. If there is no selection, If that returns #f it will move down one staff and rewind to the start of the selection in this staff..
-;TODO: After the last selected Item the cursor will move down one staff even outside the selection and will stay there. But a script with SingleAndSelectionSwitcher will NOT be applied to this outside-object and the user will not see this because the cursor is returned to the starting position afterwards.
 
+;Next object in selection for all staffs
 (define (NextSelectedObjectAllStaffs)
-	(if  (not (d-NextSelectedObject)) 
-	  (if  (and (d-MoveToStaffDown) (d-IsInSelection))
-		 (selection::MoveToStaffBeginning) ; there is a selection a staff down, loop to the beginning
-		#f ; there is no staff down or the selection is single staff.
-		)
-	  #t)) ;NextSelecetedObject was succesful
+	(define remember 1)
+	(if (and (d-MarkStatus) (d-IsInSelection))
+		(if (d-NextSelectedObject)
+		  #t ; found one. End
+		  (begin (set! remember (d-GetHorizontalPosition)) ; check one staff down and if there is a selection.
+		  	(if (d-MoveToStaffDown) 
+		  		(if (selection::MoveToStaffBeginning) 
+				  	#t ; found a selection in the lower staff
+				  	(begin (d-GoToPosition #f (- (d-GetStaff) 1) #f remember) #f)) ; reset cursor to the last known selection position
+				  #f))) ; no staff below
+	  #f)); no selection or cursor not in selection
 	
 
 
 (define (selection::MoveToStaffBeginning)
-(d-PushPosition)
- (if (d-GoToSelectionStart) ; Test if there is a selection at all
-	(begin
-		(d-PopPosition); return to the initial position to go to the correct staff
-		(d-PushPosition); save it again in case that there is no selection in this staff.
-		(d-MoveToBeginning)
-		(let loop ()  ; Real work begins here. Loop through until you found it or end of staff.
-		  (if (d-IsInSelection) 
-		  	#t ; found the first note
-			(if (d-NextObject) (loop) ; prevent endless loop if reaching the end of a staff without selection present
-				(begin  (d-PopPosition) #f ))))  ; if end of staff and no selection return to initial position and return #f
-	)
-	(begin  (d-PopPosition) #f )   ; no selection at all. 
-	)) ; fi GoToSelectionStart
+	(define rememberStaff (d-GetStaff))
+	(define rememberPosition (GetPosition))
+	(if (d-GoToSelectionStart)
+		(begin 
+			(d-GoToPosition #f rememberStaff #f #f)
+			(if (d-IsInSelection)
+				#t
+				(begin (apply d-GoToPosition rememberPosition) #f)))
+		#f)) ; no selection at all. 
 
 
 
@@ -209,6 +206,8 @@
 ;Return values are the return values the script itself gives.
 ;The third, optional, parameter can prevent an object from be processed. By default this parameter is #t so the command will be will be applied to any object in the selection and let the command itself decide what to do (or just do nothing). By giving the third optional argument you can specify additional conditions, for example with GetType. In general: Insert test conditions here, if #t the current object will be processed, otherwise it will be skipped.
 ;Example: (SingleAndSelectionSwitcher  "(d-ChangeDurationByFactorTwo *)" "(d-ChangeDurationByFactorTwo *)")
+;TODO: Get rid of eval.
+;TODO: Why is there a GoToSelectionStart AND PopPosition?
 
 (define* (SingleAndSelectionSwitcher commandsingle #:optional (commandselection commandsingle) (onlyFor "#t")) ; Amazingly commandsingle is already defined on spot so that it can be used again in the same line to define commandselection 
 	(d-PushPosition)
@@ -229,9 +228,25 @@
 	(begin	
 		(eval-string commandsingle)))) ; End of SingleAndSelectionSwitcher
 
+; MapToSelection is like schemes (map) mixed with ApplyToSelection. Use a proc on all selection items and gather all proc return values in a list.
+(define* (MapToSelection proc #:optional (onlyFor (lambda () #t)))
+	(define return (list #f))	; prepare return list
+	(define (gather)
+		(if (onlyFor) ; test the current item
+			(append! return (list (proc))) ; execute the proc and append its return value as listmember to the returnlist
+			#f))
+	(if (and DenemoPref_applytoselection (d-MarkStatus)) ; only if preferences allow it and if there is a selection at all
+		(begin 
+			(d-PushPosition)
+			(d-GoToSelectionStart)
+			(gather) ; start one without testing. We already know we have a selection and RepeatProcWhileTest tests first.
+			(RepeatProcWhileTest gather NextSelectedObjectAllStaffs) ; Use the proc/gather function on all items in the selection
+			(d-PopPosition)
+			(list-tail return 1))			
+		#f))
 
-;;; A set of simple tests / questions for score objects. 
 
+; A set of simple tests / questions for score objects. 
 (define (Music?) 
   (if (string=? (d-GetType) "CHORD") #t #f))
 	
@@ -283,7 +298,7 @@
 	
 (define (Appending?)
  (if (string=? (d-GetType) "Appending") #t #f))	 
- 
+  
 ;;;;; End set of questions
 		  
 
@@ -1927,3 +1942,6 @@
 
 ;Insert a no-pitch note of the prevailing duration.
 (define (d-Enter) (eval-string (string-append "(d-" (number->string (abs (d-GetPrevailingDuration))) ")" )))
+
+(define (GetPosition)
+	(list (d-GetMovement) (d-GetStaff) (d-GetMeasure)(d-GetHorizontalPosition)))