summaryrefslogtreecommitdiff
path: root/lib/pianosyn.lsp
diff options
context:
space:
mode:
Diffstat (limited to 'lib/pianosyn.lsp')
-rw-r--r--lib/pianosyn.lsp579
1 files changed, 579 insertions, 0 deletions
diff --git a/lib/pianosyn.lsp b/lib/pianosyn.lsp
new file mode 100644
index 0000000..9bcdfa6
--- /dev/null
+++ b/lib/pianosyn.lsp
@@ -0,0 +1,579 @@
+;; ================================================
+;; Show Program Information
+;; ================================================
+(princ "\n\nPiano Synthesizer V1.2 (Feb 2004)\n")
+(princ " Original algorithm and program by Zheng (Geoffrey) Hua\n")
+(princ " and Jim Beauchamp, University of Illinois. Any publication\n")
+(princ " or notes on any composition that utilizes this software\n")
+(princ " should credit the original creators. Any software based on\n")
+(princ " this algorithm should carry a similar notice and restriction.\n")
+(princ " Ported to Nyquist from source code in M4C program by\n")
+(princ " Ning Hu and Roger Dannenberg, Carnegie Mellon University\n")
+(princ " School of Computer Science\n\n")
+(princ " Program Initializing...\n")
+
+(setf *pianosyn-path* (current-path))
+
+;; ================================================
+;; Function definition
+;; ================================================
+(defun readdat (filename dim data)
+ (setf filename (strcat *pianosyn-path* "piano"
+ (string *file-separator*) filename))
+ (setq fp (open-binary filename :direction :input))
+ (dotimes (count 4)
+ (setf (aref dim count) (read-int fp)))
+ (dotimes (count (aref dim 3))
+ (setf (aref data count) (read-float fp)))
+ (close fp))
+
+(defun build-harmonic-phase (n phase size)
+ (sound-srate-abs size (osc (hz-to-step n) 1 *sine-table* phase)))
+
+
+;; ******************************************
+;; * Build envelope *
+;; ******************************************
+
+; after the initial envelope, which is stored in a table,
+; envelopes are extended by splicing together final segments
+; of the real envelope. The final segment is approximately
+; exponential, and so each copy of the segments that is
+; spliced is scaled by the amount of decay during the segment.
+; The long term shape will therefore be exactly exponential, but
+; we thought that a bit of variation rather than a perfectly
+; smooth exponential decay might be better.
+;
+; This function takes a segment, the amount of decay in the
+; segment (the scale factor for the next segment) and a count
+; and builds an envelope
+;
+(defun decay-env (segment decay count)
+ (cond ((<= count 1) (cue segment))
+ (t (seq (cue segment)
+ (scale decay (decay-env segment decay (1- count)))))))
+
+; PIANO-ENVELOPE builds the amplitude envelope for a group of partials.
+; igroup is the index of the group
+; sc-duration is the score duration
+; attack is the sampled portion of the envelope with a duration of
+; gmagendtime
+; seg-array is the repeating portion of the envelope tacked onto
+; attack to make the envelope longer. The duration of a segment
+; in seg-array is gmagendtimemini
+; the amount by which seg-array[igroup] decays is scalemag1[igroup]
+;
+; Algorithm:
+; figure out how many repetitions of the seq-array[igroup] to
+; add onto the attack to make the envelope long enough. Multiply
+; by an exponential decay starting at the duration -- effectively
+; the damper hits the string at sc-duration.
+;
+(defun piano-envelope (igroup sc-duration gmagendtime gmagendtimemini
+ attack seg-array scalegmag1)
+ (let ((decaycount (1+ (truncate (/ (- (+ sc-duration endingtime) gmagendtime)
+ gmagendtimemini))))
+ pianoenv )
+
+ (setf pianoenv
+ (sim (at 0 (cue attack))
+ (at gmagendtime (decay-env (aref seg-array igroup)
+ (aref scalegmag1 igroup)
+ decaycount))))
+ ;; For ending time
+ (mult (scale (aref scale1 igroup) pianoenv)
+ (pwlv 1 sc-duration
+ ; decay to 1/1000: about 60dB
+ 1 (+ sc-duration endingtime) 0.001))))
+
+
+;; ******************************************
+;; * Build wavetable *
+;; ******************************************
+(defun piano-group (jgroup sc-duration freq table)
+ (sound-srate-abs *piano-srate*
+ (osc (hz-to-step freq) sc-duration
+ (aref table jgroup))))
+
+;; ******************************************
+;; * Produce single piano note *
+;; ******************************************
+(defun piano-note (duration pitch dynamic)
+ (let ((ioi (get-duration duration))
+ (full-pitch (+ (get-transpose) pitch))
+ (full-dynamic (+ (get-loud) dynamic))
+ ;; note: the "loud" is nominally in dB, but
+ ;; piano-note-abs uses something akin to midi velocity
+ ;; we should probably work out a better conversion
+ (start-time (local-to-global 0))
+ on-dur)
+ (setf on-dur (* ioi (get-sustain)))
+ (set-logical-stop
+ (abs-env (at start-time
+ (piano-note-abs on-dur full-pitch full-dynamic)))
+ ioi)))
+
+
+;; PIANO-NOTE-ABS -- private function to do the work; assumes
+;; stretch factor of 1, etc.
+(defun piano-note-abs (sc-duration sc-pitch sc-dynamic)
+ (let (attnamp freq key whichone whichone1 ngroup1 ngroup2 dyna smax
+ dur gmagendtime gmagendtimemini k j envpoint)
+ ;; ******************************************
+ ;; * Initilization for each note *
+ ;; ******************************************
+ (setq attnamp 0.03)
+
+ ; key is midi pitch number
+ (setq key (truncate (+ sc-pitch 0.000001)))
+ (cond ((< key 21) ;; 21 is A0, lowest pitch on this piano
+ (break "piano-note-abs pitch is too low" sc-pitch)
+ ;; continued -- transpose up to lowest octave
+ (while (< key 21)
+ (setf sc-pitch (+ sc-pitch 12))
+ (setf key (truncate (+ sc-pitch 0.000001)))))
+ ((> key 108) ;; 108 is c9, highest pitch on this piano
+ (break "piano-note-abs pitch is too high" sc-pitch)
+ ;; continued -- transpose down to highest octave
+ (while (> key 108)
+ (setf sc-pitch (- sc-pitch 12))
+ (setf key (truncate (+ sc-pitch 0.000001))))))
+ (setq freq (step-to-hz sc-pitch))
+
+ (setq whichone -2)
+ (dotimes (i GROUPCON)
+ (if (and (= whichone -2)
+ (< freq (- (aref fa i) 0.001)))
+ (setq whichone (- i 1))))
+ ;; Have to use (- (aref fa i) 0.001) because of the calculation precision of Nyquist
+
+ (setq whichone1 (1+ whichone))
+ (setq ngroup2 (aref ngroup whichone1))
+
+ (setq dyna (truncate sc-dynamic))
+ (setq smax 0.25)
+
+ ; (setq attnpretime (/ (+ (* 0.018 dyna dyna) (* -3.9588 dyna) 244.8139) 1000.0))
+ (setq dur (aref durtab (+ (* key 128) dyna)))
+ (setq ngroup1 (aref ngroup whichone))
+ (setq gmagendtime (* (nth whichone hkframe) (aref dt whichone)))
+ (setq gmagendtimemini (* (aref nptsmini whichone) (aref dtmini whichone)))
+
+ (setq k (* (aref gmaxtabdim 1) (aref gmaxtabdim 2)))
+ (setq j (+ (* whichone k) (* dyna (aref gmaxtabdim 2))))
+ (dotimes (i (aref gmaxtabdim 2))
+ (setf (aref gmax1 i) (aref gmaxtab j))
+ (incf j))
+
+ (dotimes (i ngroup1)
+ (setq envpoint (sref (aref (aref gmagmini whichone) i) 0))
+ (if (/= envpoint 0)
+ (setf (aref scalegmag1 i)
+ (/ (sref (aref (aref gmagmini whichone) i)
+ (- gmagendtimemini (aref dtmini whichone)))
+ envpoint))
+ (setf (aref scalegmag1 i) 0.0))
+ (setf (aref scale1 i) (* smax (aref gmax1 i))))
+ (if (> ngroup2 ngroup1) (setf ngroup2 ngroup1))
+
+ (if (< dur sc-duration) (setq sc-duration dur))
+ ;; **********************
+ ;; * now sum the groups *
+ ;; **********************
+ (scale 0.5
+ (sim (at 0 (set-logical-stop (cue (scale attnamp attsound)) sc-duration))
+ (at 0 (cue (simrep (i ngroup2)
+ (mult (piano-envelope i sc-duration gmagendtime
+ gmagendtimemini (aref (aref gmag whichone) i)
+ (aref gmagmini whichone) scalegmag1)
+ (piano-group i (+ sc-duration endingtime) freq
+ (aref wavetab whichone1)))))))) ))
+;;;;; This is for debugging -- replace synthesis with a sine tone to study envelope
+; (at 0 (cue (mult (piano-envelope 0 sc-duration gmagendtime
+; gmagendtimemini (aref (aref gmag whichone) 0)
+; (aref gmagmini whichone) scalegmag1)
+; (osc c4 2.0))))))))
+
+
+(defun piano-note-2 (sc-pitch sc-dynamic)
+ (let ((dur (get-duration 1)))
+ (stretch-abs 1 (piano-note dur sc-pitch sc-dynamic))))
+
+
+(defun piano-midi (midiin)
+ (let (midi-seq midifile)
+ (setf midi-seq (seq-create))
+ (setf midifile (open-binary midiin))
+ (seq-read-smf midi-seq midifile)
+ (close midifile)
+ (seq-midi midi-seq
+ (note (channel pitch velocity)
+ (piano-note-2 pitch velocity)))))
+
+
+;; ******************************************
+;; *Produce wave file according to MIDI file*
+;; ******************************************
+(defun piano-midi2file (midiin out-name)
+ (princ "\nBegin sound production\n")
+ (princ "=============================================\n")
+ (s-save (piano-midi midiin)
+ ny:all (string out-name) :play T)
+ (princ "=============================================\n")
+ (princ "End sound production\n"))
+
+
+;; ====================================
+;; Main Program
+;; ====================================
+(if (not (boundp '*piano-srate*)) ;; if pianosyn.lsp wasn't loaded already
+ (expand 70)) ;; we'll allocate a lot of nodes for data, so expand now
+(setf *pianosyn-save-gc-flag* *gc-flag*)
+(setf *gc-flag* nil) ;; we'll do a lot of gc, so turn off messages
+;; Definite some constant
+(setq NPITCH 22 GROUPCON 23)
+(setq MAXAMP 32767.0)
+(setq TWOPI (+ pi pi))
+(setq *piano-srate* *default-sound-srate*)
+(setq bits 32)
+;; 512 gives pretty good SNR for interpolated sines
+;; some tables will be larger: 512 is just the minimum
+(setq tabsize 512)
+
+;; For ending time, use 30 msec. (This was originally 0.1 msec,
+;; about 4 samples, but that's too short to avoid clicks.)
+;; This not only must avoid clicks but it simulates the damper.
+;; This is the time to decay to 0.001 of the original, so it's
+;; actually quite a rapid decay.
+(setq endingtime 0.03)
+
+(setf hkframe (list 66 73 82 90 99 108 116 123 130 135 138 140 138
+ 133 126 117 107 102 105 127 153 187 200))
+(setf attsratelist (list 8000 11025 16000 22050 32000 44100 48000))
+(setf gmax1 (make-array GROUPCON))
+(setf scalegmag1 (make-array GROUPCON))
+(setf scale1 (make-array GROUPCON))
+(setf wavetab (make-array GROUPCON))
+(setf ti (make-array GROUPCON))
+(setf tstep (make-array GROUPCON))
+(setf gmaxtabdim (make-array 4))
+(setf gmaxtab (make-array 64768))
+(setf durtabdim (make-array 4))
+(setf durtab (make-array 16384))
+(setf rlsratetabdim (make-array 4))
+(setf rlsratetab (make-array 11392))
+(setf fa (make-array GROUPCON))
+(setf dt (make-array GROUPCON))
+(setf ngroup (make-array GROUPCON))
+(setf npts (make-array GROUPCON))
+(setf gmag (make-array GROUPCON))
+(setf nhar (make-array GROUPCON))
+
+(setf gmagmini (make-array GROUPCON))
+(setf dtmini (make-array GROUPCON))
+(setf nptsmini (make-array GROUPCON))
+
+(setf cw (make-array GROUPCON))
+(setf phase (make-array GROUPCON))
+(setf hfrom (make-array GROUPCON))
+(setf hto (make-array GROUPCON))
+
+(setf *zero-table* (scale 0 (build-harmonic 1 tabsize)))
+
+;; =================================================
+;; run-once initilization: pianoActor construction
+;; =================================================
+(princ "\nBegin Instrument-wise initialization...\n")
+(princ "=======================================\n")
+(princ "Reading source files:\n")
+
+
+;; Read gmax.tab
+(readdat "gmax.tab" gmaxtabdim gmaxtab)
+
+;; Read dur.tab
+(readdat "dur.tab" durtabdim durtab)
+
+;; Read rlsrate.tab
+(readdat "rlsrate.tab" rlsratetabdim rlsratetab)
+
+;; Read cwxx.cwd
+(dotimes (pncount GROUPCON)
+ (format t "~A " pncount)
+ (setq filename (strcat "pn"
+ (string (int-char (+ (truncate (/ pncount 10)) 48)))
+ (string (int-char (+ (rem pncount 10) 48)))
+ ".cod"))
+ (setq filename (strcat *pianosyn-path* "piano"
+ (string *file-separator*) filename))
+ (setq fp (open-binary filename))
+
+ ;; Read cwdHdr in cwxx.cwd
+ (setq cwdHdr-ckID (read-int fp) cwdHdr-type (read-int fp))
+ ;; "CNDN" == 1129202766
+
+ ;; That is for "FORM"==cwdHdr-ckID
+ ;;(if (and (= cwdHdr-ckID 1179603533) (= cwdHdr-type 1129202766))
+ ;; ()
+ ;; (error "Error in reading chunk header."))
+
+ ;;That is for "SYNC"==cwdHdr-ckID
+ (if (and (= cwdHdr-ckID 1398361667) (= cwdHdr-type 1129202766))
+ ()
+ (error "Error in reading chunk header."))
+
+ ;; Read COMMCK in cwxx.cwd
+ (setq COMMCK-ckID (read-int fp))
+ (if (= COMMCK-ckID 1129270605) () (error "COMMCK chunk not found."))
+ (setq COMMCK-fa (read-float fp) COMMCK-dt (read-float fp))
+ (setf (aref fa pncount) COMMCK-fa)
+ (setf (aref dt pncount) COMMCK-dt)
+ (setf (aref dtmini pncount) (* 10 COMMCK-dt))
+ (setq COMMCK-npts (read-int fp) COMMCK-ngroup (read-int fp))
+ (setf (aref npts pncount) COMMCK-npts)
+ (setf (aref nptsmini pncount)
+ (truncate (/ (+ 9 (- COMMCK-npts (nth pncount hkframe))) 10)))
+ (setf (aref ngroup pncount) COMMCK-ngroup)
+
+ ;; Read DATACK in cwxx.cwd
+ (setq DATACK-ckID (read-int fp))
+ (if (= DATACK-ckID 1346458196) () (error "DATACK chunk not found."))
+ (setf (aref nhar pncount) (read-int fp))
+ (setf (aref cw pncount) (make-array (aref nhar pncount)))
+ (setf (aref phase pncount) (make-array (aref nhar pncount)))
+ (dotimes (count (aref nhar pncount))
+ (setf (aref (aref cw pncount) count) (read-float fp)))
+ (dotimes (count (aref nhar pncount))
+ (setf (aref (aref phase pncount) count) (read-float fp)))
+
+ ;; Read GRUPCK in cwxx.cwd
+ (setq GRUPCK-ckID (read-int fp))
+ (if (= GRUPCK-ckID 1196578128) () (error "GRUPCK chunk not found."))
+ (setf (aref hfrom pncount) (make-array (aref ngroup pncount)))
+ (setf (aref hto pncount) (make-array (aref ngroup pncount)))
+ ;(display "reading grupck" (aref ngroup pncount) (aref nhar pncount) pncount)
+ (dotimes (count (aref ngroup pncount))
+ (setf (aref (aref hfrom pncount) count)
+ (read-float fp)))
+ (dotimes (count (aref ngroup pncount))
+ (setf (aref (aref hto pncount) count) (read-float fp)))
+
+ ;; Read GMAGCK in cwxx.cwd
+ (setq GMAGCK-ckID (read-int fp))
+ (if (= GMAGCK-ckID 1196245319)
+ ()
+ (error "GMAGCK chunk not found."))
+ (setq gmaghead (read-int fp))
+ (close fp)
+ (setf (aref gmag pncount) (make-array (aref ngroup pncount)))
+ (setq gmagrate (/ 1 (aref dt pncount)))
+ (setq gmagdur (/ (nth pncount hkframe) gmagrate))
+
+ ; (display "gmagmini" pncount (aref ngroup pncount))
+ (setf (aref gmagmini pncount) (make-array (aref ngroup pncount)))
+ (setq gmagratemini (/ 1 (aref dtmini pncount)))
+ (setq gmagdurmini (/ (aref nptsmini pncount) gmagratemini))
+
+ (dotimes (i (aref ngroup pncount))
+ (let (gmaghead1 samps gmaghead1mini)
+ (setf gmaghead1 (/ (float gmaghead) (* gmagrate (/ bits 8))))
+ ;(display "gmag read" i gmaghead1 gmagrate filename)
+ (setf samps (s-read filename :time-offset gmaghead1 :srate gmagrate
+ :dur gmagdur :mode snd-mode-float
+ :format snd-head-raw :bits bits :endian :big))
+ (if samps (snd-length samps ny:all)) ; force read into memory
+ (setf (aref (aref gmag pncount) i) samps)
+ (setq gmaghead (+ gmaghead (* 4 (nth pncount hkframe))))
+ (setq gmaghead1mini (/ (float gmaghead) (* gmagratemini (/ bits 8))))
+ ;(display "gmag read mini" i gmaghead1mini gmagratemini filename)
+ (setf samps (s-read filename :time-offset gmaghead1mini :srate gmagratemini
+ :dur gmagdurmini :mode snd-mode-float :format snd-head-raw
+ :bits bits :endian :big))
+ (if samps (snd-length samps ny:all)) ; force read into memory
+ ;(display "read gmagmini" filename pncount i
+ ; (if samps (snd-length samps ny:all)))
+ (setf (aref (aref gmagmini pncount) i) samps)
+ (setq gmaghead (+ gmaghead (* 4 (aref nptsmini pncount))))
+ ))
+)
+
+(setq maxfreq (aref fa (1- GROUPCON)))
+(dotimes (i GROUPCON)
+ (setq ngrouptemp -1)
+ (dotimes (j (aref ngroup i))
+ (if (and (= ngrouptemp -1)
+ (>= (* (aref (aref hto i) j) (aref fa i))
+ (/ *piano-srate* 2)))
+ (setq ngrouptemp j)))
+ (if (>= ngrouptemp 0) (setf (aref ngroup i) ngrouptemp)))
+
+(princ "\nGenerating wavetables...\n")
+(setq tempi (/ (* 360 tabsize) (* TWOPI TWOPI)))
+(dotimes (h GROUPCON)
+ (setf (aref wavetab h) (make-array (aref ngroup h)))
+ (dotimes (i (aref ngroup h))
+ ;(FORMAT T "WAVE ~A OF GROUP ~A~%" i h)
+ (let ((low (aref (aref hfrom h) i))
+ (high (aref (aref hto h) i))
+ tempphase tempcw
+ (len tabsize))
+ ; table size must be more than twice greatest harmonic number
+ ; use a factor of three so we have a wider margin of oversampling
+ (setf len (max len (* 3 high)))
+ (setf sumwave *zero-table*)
+ (do ((k (truncate low) (incf k)))
+ ((> k high))
+ (cond ((< k (aref nhar h))
+ (setq tempphase (aref (aref phase h) k))
+ (setq tempcw (aref (aref cw h) k)))
+ (t
+ (setq tempphase 0)
+ (setq tempcw 0)))
+ (setf sumwave (sum sumwave (scale tempcw (build-harmonic-phase k
+ (+ (* tempphase tempi) 90.0)
+ len))))))
+ ;(PRINT "FORCE SUMMATION OF WAVE")
+ (snd-length sumwave ny:all) ; force summation
+ ;( "END SUMMATION OF WAVE")
+ (setf (aref (aref wavetab h) i) (list sumwave (hz-to-step 1) T))))
+
+;; Read in attack sound
+(princ "\nRead in attack sound...\n")
+(setq attndur 0.5)
+(setq attnth -1)
+(dotimes (count (length attsratelist))
+ (if (and (= attnth -1) (<= *piano-srate* (nth count attsratelist))) (setq attnth count)))
+(if (or (= attnth -1) (/= (nth attnth attsratelist) *piano-srate*))
+ (princ "No attack sound rate corresponds to current sound rate, use the nearest one\n"))
+(if (> attnth 0)
+ (if (<= (- (nth attnth attsratelist) *piano-srate*) (- *piano-srate* (nth (1- attnth) attsratelist)))
+ (setq attsrate (nth attnth attsratelist)) (setq attsrate (nth (1- attnth) attsratelist)))
+ (case attnth
+ (-1 (setq attsrate (last attsratelist)))
+ (0 (setq attsrate (nth 0 attsratelist)))))
+(setq filename (format nil "att~A.pcm" (truncate attsrate)))
+(setf filename (strcat *pianosyn-path* "piano"
+ (string *file-separator*) filename))
+(setf attsound
+ (s-read filename :srate attsrate :dur attndur :format snd-head-raw
+ :mode snd-mode-pcm :bits 16 :endian :big))
+
+(princ "=============================================\n")
+(princ "End instrument-wise initialization\n")
+(princ "\n\n=============================================\n")
+(princ "Piano Synthesizer function definition:\n")
+(princ "(piano-note-2 step dynamic)\n")
+(princ "(piano-note duration step dynamic)\n")
+(princ "(piano-midi midi-file-name)\n")
+(princ "(piano-midi2file midi-file-name sound-file-name)\n\n")
+(princ "=============================================\n")
+(setf *gc-flag* *pianosyn-save-gc-flag*) ;; restore original value
+
+
+#|
+
+;;================= DEBUGGING CODE =========================
+;;
+;; run (show-cn-file n) to dump some data from pn??.cod
+;;
+;;==========================================================
+
+
+;; INT-HEX -- convert integer to hex string
+;;
+(defun int-hex (int)
+ (let ((result "") ch)
+ (while (/= int 0)
+ (setf ch (char "0123456789ABCDEF" (logand int 15)))
+ (setf result (strcat (string ch) result))
+ (setf int (/ int 16)))
+ (if (equal result "") "0" result)))
+
+(defun int-4char (int)
+ (strcat (string (int-char (logand 255 (/ int (* 256 256 256)))))
+ (string (int-char (logand 255 (/ int (* 256 256)))))
+ (string (int-char (logand 255 (/ int 256))))
+ (string (int-char (logand 255 int)))))
+
+(defun show-cn-file (pncount)
+ (let (filename fp cwdhdr-ckid cwdhdr-type)
+ (setq filename (strcat "pn"
+ (string (int-char (+ (truncate (/ pncount 10)) 48)))
+ (string (int-char (+ (rem pncount 10) 48)))
+ ".cod"))
+ (setf filename (strcat *pianosyn-path* "piano"
+ (string *file-separator*) filename))
+ (format t "SHOW-CN-FILE ~A (~A)~%" pncount filename)
+ (setf fp (open-binary filename))
+ ;; Read cwdHdr in cwxx.cwd
+ (setq cwdHdr-ckID (read-int fp) cwdHdr-type (read-int fp))
+ (format t "header ckID: ~A (~A)~%" (int-hex cwdhdr-ckid)
+ (int-4char cwdhdr-ckid))
+ (format t "header type: ~A (~A)~%" (int-hex cwdhdr-type)
+ (int-4char cwdhdr-type))
+ (setq COMMCK-ckID (read-int fp))
+ (format t "header ckID: ~A (~A)~%" (int-hex commck-ckid)
+ (int-4char commck-ckid))
+ (setq COMMCK-fa (read-float fp) COMMCK-dt (read-float fp))
+ (format t "commck-fa ~A commck-dt ~A~%" commck-fa commck-dt)
+ (setq COMMCK-npts (read-int fp) COMMCK-ngroup (read-int fp))
+ (format t "commck-npts ~A commck-ngroup ~A~%" commck-npts commck-ngroup)
+ (setq DATACK-ckID (read-int fp))
+ (format t "header ckID: ~A (~A)~%" (int-hex datack-ckid)
+ (int-4char datack-ckid))
+ (setf datack-nhar (read-int fp))
+ (format t "datack-nhar ~A~%cw data:" datack-nhar)
+ (dotimes (i datack-nhar)
+ (if (and (zerop (rem i 10)) (or (< i 10) (> i (- datack-nhar 10))))
+ (format t "~% ~A:" i))
+ (setf data-cw (read-float fp))
+ (if (or (< i 10) (>= i (* (/ datack-nhar 10) 10)))
+ (format t " ~A" data-cw)))
+ (format t "~%phase data:")
+ (dotimes (i datack-nhar)
+ (if (and (zerop (rem i 10)) (or (< i 10) (> i (- datack-nhar 10))))
+ (format t "~% ~A:" i))
+ (setf data-phase (read-float fp))
+ (if (or (< i 10) (> i (- datack-nhar 10))) (format t " ~A" data-cw)))
+ (format t "~%")
+ (setf grupck-ckid (read-int fp))
+ (format t "header ckID: ~A (~A)~%hfrom data:"
+ (int-hex grupck-ckid) (int-4char grupck-ckid))
+ (dotimes (count commck-ngroup)
+ (setf data-hfrom (read-float fp))
+ (if (zerop (rem count 10))
+ (format t "~% ~A:" count))
+ (format t " ~A" data-hfrom))
+ (format t "~%hto data:")
+ (dotimes (count commck-ngroup)
+ (setf data-hto (read-float fp))
+ (if (zerop (rem count 10))
+ (format t "~% ~A:" count))
+ (format t " ~A" data-hto))
+ (setf gmagck-ckid (read-int fp))
+ (format t "~%header ckID: ~A (~A)~%"
+ (int-hex gmagck-ckid) (int-4char gmagck-ckid))
+ (setf gmaghead (read-int fp))
+ (format t "gmaghead ~A" gmaghead)
+ (format t "~%")
+ ;; compute range of data to be read
+ (setf offset gmaghead)
+ (dotimes (i commck-ngroup)
+ (format t "gmag: group ~A offset ~A length ~A end ~A~%"
+ i offset (* 4 (nth pncount hkframe))
+ (+ offset (* 4 (nth pncount hkframe))))
+ (setf offset (+ offset (* 4 (nth pncount hkframe))))
+ (format t "gmagmini: group ~A offset ~A length ~A end ~A~%"
+ i offset (* 4 (aref nptsmini pncount))
+ (+ offset (* 4 (aref nptsmini pncount))))
+ (setf offset (+ offset (* 4 (aref nptsmini pncount)))))
+
+ (close fp)
+
+ (setf gmag-and-gmagmini
+ (s-read filename
+ :time-offset (* (float gmaghead) 0.25 commck-dt)
+ :srate (/ 1.0 commck-dt)
+ :mode snd-mode-float :format snd-head-raw
+ :bits 32 :endian :big))))
+|#
generated by cgit v1.2.3 (git 2.25.1) at 2024-04-23 06:02:33 +0000