Source Code for MIDI Player (In-Process)

Functions in Class Collection.MIDI

! Collection_MIDI.f
! - DLL routines for class <Reference>Collection.MIDI
! DATE: Sunday, April 21, 2002 TIME: 04:53:35 PM
! The skeleton of this file is generated by SansGUI(tm)

! Attribute indices in class version [1.0.0.0]
! 1: cFileName - MIDI File Name
! 2: cShareName - Unique Name for Shared Memory
! 3: fInterval - Sampling Interval
! 4: fTime - Current Sampling Time
! 5: iHandle - Shared Memory Handle
! 6: iMemory - Shared Memory Pointer
! 7: iChannel - Current MIDI Channel
! 8: iData - Current MIDI Data

! ======================================================================
! SG_xInit - Initialization
! ----------------------------------------------------------------------
      integer function SG_xInit_Collection_MIDI(self,                   &
     &                        simCtrl, chgChild,                        &
     &                        pRefObjs, iRefObjs,                       &
     &                        pAdjObjs, iAdjObjs,                       &
     &                        pLnkObjs, iLnkObjs,                       &
     &                        cMessage, cCommand, pOutFile )
!DEC$ IF DEFINED (_DLL)
!DEC$ ATTRIBUTES DLLEXPORT :: SG_xInit_Collection_MIDI

!DEC$ END IF

      use dfwin

      include "SGdllf.h"

      ! TODO: declare your local variables here

      integer(4) :: hMappedFile
      integer(4) :: pSharedMem
      integer(4) :: iStrLength
      real*4, dimension(*) :: fTime
      integer, dimension(*) :: iHandle
      integer, dimension(*) :: iMemory
      character, dimension(*) :: cShareName
      POINTER(PTR_cShareName, cShareName)
      POINTER(PTR_fTime, fTime)
      POINTER(PTR_iHandle, iHandle)
      POINTER(PTR_iMemory, iMemory)
      integer, parameter :: SG_NDX_CSHARENAME = 2
      integer, parameter :: SG_NDX_FTIME = 4
      integer, parameter :: SG_NDX_IHANDLE = 5
      integer, parameter :: SG_NDX_IMEMORY = 6
      integer :: convertStringCtoF, iLen
      character(SG_STR_LEN + 1) :: cName

      if (self%nSGobjSchema .ne. SG_OBJ_SCHEMA) then
          SG_xInit_Collection_MIDI = SG_R_SCHM
          return
      end if

      ! TODO: put your simulator code here

      PTR_zValues = self%pzValues
      PTR_cShareName = zValues(SG_NDX_CSHARENAME)%vData
      iStrLength = zValues(SG_NDX_CSHARENAME)%iCols

      iLen = convertStringCtoF(cName, cShareName, 0)
      hMappedFile = OPENFILEMAPPING(PAGE_READONLY, 0, cName)

      if (hMappedFile .eq. 0) then
          cMessage =
     &'Invoke external process simulator and check shared memory name.'C
      SG_xInit_Collection_MIDI = SG_R_STOP
      return
      end if

      pSharedMem = MAPVIEWOFFILE(hMappedFile,FILE_MAP_ALL_ACCESS,0,0,0)
      if (pSharedMem .eq. 0) then
          cMessage = 'Cannot map shared memory.'C
          SG_xInit_Collection_MIDI = SG_R_STOP
          return
      end if

      ! successful, register the handle and the shared memory pointer
      PTR_iHandle = zValues(SG_NDX_IHANDLE)%vData
      PTR_iMemory = zValues(SG_NDX_IMEMORY)%vData
      iHandle(1) = hMappedFile
      iMemory(1) = pSharedMem

      ! reset current sampling time
      PTR_fTime = zValues(SG_NDX_FTIME)%vData
      fTime(1) = 0.

      SG_xInit_Collection_MIDI = SG_R_OK
      return
      end

! ======================================================================
! SG_xPreEval - Pre-Evaluation
! ----------------------------------------------------------------------
integer function SG_xPreEval_Collection_MIDI(self,                      &
     &                        simCtrl, chgChild,                        &
     &                        pRefObjs, iRefObjs,                       &
     &                        pAdjObjs, iAdjObjs,                       &
     &                        pLnkObjs, iLnkObjs,                       &
     &                        cMessage, cCommand, pOutFile )
!DEC$ IF DEFINED (_DLL)
!DEC$ ATTRIBUTES DLLEXPORT :: SG_xPreEval_Collection_MIDI
!DEC$ END IF

      include "SGdllf.h"

      ! TODO: declare your local variables here

      integer(4) :: hMappedFile
      integer(4) :: pSharedMem
      integer, dimension(*) :: iHandle
      integer, dimension(*) :: iMemory
      integer, dimension(*) :: iChannel
      integer, dimension(*) :: iDataM
      integer, dimension(2) :: iSharedData ! 1-Channel, 2-Data
      logical :: bRet
      POINTER(PTR_iHandle, iHandle)
      POINTER(PTR_iMemory, iMemory)
      POINTER(PTR_iChannel, iChannel)
      POINTER(PTR_iDataM, iDataM)
      POINTER(PTR_iSharedData, iSharedData)
      integer, parameter :: SG_NDX_IHANDLE = 5
      integer, parameter :: SG_NDX_IMEMORY = 6
      integer, parameter :: SG_NDX_ICHANNEL = 7
      integer, parameter :: SG_NDX_IDATA = 8

      if (self%nSGobjSchema .ne. SG_OBJ_SCHEMA) then
          SG_xPreEval_Collection_MIDI = SG_R_SCHM
          return
      end if

      ! TODO: put your simulator code here

      PTR_zValues = self%pzValues
      PTR_iHandle = zValues(SG_NDX_IHANDLE)%vData
      PTR_iMemory = zValues(SG_NDX_IMEMORY)%vData
      PTR_iChannel = zValues(SG_NDX_ICHANNEL)%vData
      PTR_iDataM = zValues(SG_NDX_IDATA)%vData

      ! fetch the handle and shared memory address
      hMappedFile = iHandle(1)
      pSharedMem = iMemory(1)
      ! map the shared memory to two integers
      PTR_iSharedData = pSharedMem

      ! when the channel number is negative, the MIDI player has ended
      if (iSharedData(1) .lt. 0) then
          cMessage = 'External Process Simulator has been terminated.'C
          if (pSharedMem .ne. 0) then
              bRet = UNMAPVIEWOFFILE(pSharedMem)
          end if
          if (hMappedFile .ne. 0) then
              bRet = CLOSEHANDLE(hMappedFile)
          end if
          SG_xPreEval_Collection_MIDI = SG_R_STOP
          return
      end if

      ! still playing, copy the channel number and the data field from
      ! the shared memory
      iChannel(1) = iSharedData(1)
      iDataM(1) = iSharedData(2)

      SG_xPreEval_Collection_MIDI = SG_R_OK
      return
      end

! ======================================================================
! SG_xPostEval - Post-Evaluation
! ----------------------------------------------------------------------
integer function SG_xPostEval_Collection_MIDI(self,                     &
     &                        simCtrl, chgChild,                        &
     &                        pRefObjs, iRefObjs,                       &
     &                        pAdjObjs, iAdjObjs,                       &
     &                        pLnkObjs, iLnkObjs,                       &
     &                        cMessage, cCommand, pOutFile )
!DEC$ IF DEFINED (_DLL)
!DEC$ ATTRIBUTES DLLEXPORT :: SG_xPostEval_Collection_MIDI
!DEC$ END IF

      include "SGdllf.h"

      ! TODO: declare your local variables here

      real*4, dimension(*) :: fInterval
      real*4, dimension(*) :: fTime
      POINTER(PTR_fInterval, fInterval)
      POINTER(PTR_fTime, fTime)
      integer, parameter :: SG_NDX_FINTERVAL = 3
      integer, parameter :: SG_NDX_FTIME = 4

      if (self%nSGobjSchema .ne. SG_OBJ_SCHEMA) then
          SG_xPostEval_Collection_MIDI = SG_R_SCHM
          return
      end if

      ! TODO: put your simulator code here

      PTR_zValues = self%pzValues
      PTR_fInterval = zValues(SG_NDX_FINTERVAL)%vData
      PTR_fTime = zValues(SG_NDX_FTIME)%vData

      if (fInterval(1) .gt. 0.) then
          ! if interval is specified, sleep until the next time
          call SLEEPQQ(INT(fInterval(1)))
          ! advance current time register
          fTime(1) = fTime(1) + fInterval(1)
      else
          ! we just do as quick as we can and indicate 1 millisecond per cycle
          fTime(1) = fTime(1) + 1.0
      end if

      SG_xPostEval_Collection_MIDI = SG_R_OK
      return
      end

! ======================================================================
! SG_xEndRun - End Run
! ----------------------------------------------------------------------
integer function SG_xEndRun_Collection_MIDI(self,                       &
     &                        simCtrl, chgChild,                        &
     &                        pRefObjs, iRefObjs,                       &
     &                        pAdjObjs, iAdjObjs,                       &
     &                        pLnkObjs, iLnkObjs,                       &
     &                        cMessage, cCommand, pOutFile )
!DEC$ IF DEFINED (_DLL)
!DEC$ ATTRIBUTES DLLEXPORT :: SG_xEndRun_Collection_MIDI
!DEC$ END IF

      include "SGdllf.h"

      ! TODO: declare your local variables here

      integer(4) :: hMappedFile
      integer(4) :: pSharedMem
      integer, dimension(*) :: iHandle
      integer, dimension(*) :: iMemory
      logical :: bRet
      POINTER(PTR_iHandle, iHandle)
      POINTER(PTR_iMemory, iMemory)
      integer, parameter :: SG_NDX_IHANDLE = 5
      integer, parameter :: SG_NDX_IMEMORY = 6

      if (self%nSGobjSchema .ne. SG_OBJ_SCHEMA) then
          SG_xEndRun_Collection_MIDI = SG_R_SCHM
          return
      end if

      ! TODO: put your simulator code here

      PTR_zValues = self%pzValues
      PTR_iHandle = zValues(SG_NDX_IHANDLE)%vData
      PTR_iMemory = zValues(SG_NDX_IMEMORY)%vData

      ! fetch the handle and shared memory address
      hMappedFile = iHandle(1)
      pSharedMem = iMemory(1)

      ! do clean up here
      if (pSharedMem .ne. 0) then
          bRet = UNMAPVIEWOFFILE(pSharedMem)
      end if
      if (hMappedFile .ne. 0) then
          bRet = CLOSEHANDLE(hMappedFile)
      end if

      ! if the user terminated the MIDIplayer prematurely, StopReq status
      ! bit is set by SansGUI to inform the simulator.
      if (JIAND(simCtrl%iStatus, SG_STAT_STOP) .ne. 0) then
          cMessage =
     &    'User STOP request detected - simulation resources released.'C
      SG_xEndRun_Collection_MIDI = SG_R_LMSG
      return
      end if

      SG_xEndRun_Collection_MIDI = SG_R_OK
      return
      end

! ======================================================================
! get_MIDI_Channel_Data - service routine to fetch MIDI channel number
! and data from this object (self)
! ----------------------------------------------------------------------
! ARGUMENTS:
! self -      the MIDI object containing information to be copied
! iMidiData - the data returned, will be updated by this function
!
! RETURN VALUE:
! The channel number from the MIDI event
! ----------------------------------------------------------------------
integer function get_MIDI_Channel_Data(self, iMidiData)
      ! We define SG_NO_API before the inclusion of SGdllf.h because
      ! this service function is not one of the DLL entry points.
      ! Only the definitions of SG_VALU and SG_OBJ are needed here.
cDEC$ DEFINE SG_NO_API
include "SGdllf.h"
cDEC$ UNDEFINE SG_NO_API
      type (SG_OBJ) :: self
      integer :: iMidiData
      intent (out) iMidiData

      type (SG_VALU), dimension(*) :: zValues
      integer, dimension(*) :: iChannel
      integer, dimension(*) :: iDataM
      POINTER(PTR_zValues, zValues)
      POINTER(PTR_iChannel, iChannel)
      POINTER(PTR_iDataM, iDataM)
      integer, parameter :: SG_NDX_ICHANNEL = 7
      integer, parameter :: SG_NDX_IDATA = 8

      PTR_zValues = self%pzValues
      PTR_iChannel = zValues(SG_NDX_ICHANNEL)%vData
      PTR_iDataM = zValues(SG_NDX_IDATA)%vData

      iMidiData = iDataM(1)
      get_MIDI_Channel_Data = iChannel(1)
      return
      end

! ======================================================================
! convertStringCtoF - convert a C string to a Fortran string
! ----------------------------------------------------------------------
! ARGUMENTS:
! strF -    Fortran string, declared as a character array (string)
! strC -    C string, a pointer to a Null-terminated character
!           array. It is declared as an array of 1 char strings
! iMaxLen - maximum number of characters
!           (.eq. 0) copy up to and include the NULL character in
!                    the C string. If the Fortran string contains
!                    fewer character spaces, it will have a truncated
!                    string with the last character being NULL.
!           (.gt. 0) copy exactly iMaxLen characters or up to the
!                    length of strF. If the Fortran string is
!                    longer, fill in the rest with space character.
!           (.lt. 0) copy exactly -iMaxLen characters or up to the
!                    length of strF. If the Fortran string is
!                    longer, the rest of the string will not be
!                    changed.
!           Thus, only (.eq. 0) will result in null-terminated
!           string in the Fortran string.
! RETURN VALUE:
! The number of characters copied (excluding NULL in .eq. 0 case)
! ----------------------------------------------------------------------
integer function convertStringCtoF(strF, strC, iMaxLen)
      character(*) :: strF
      character, dimension(*) :: strC
      integer :: iMaxLen
      intent (in) strC, iMaxLen

      integer :: iMaxLenAbs ! absolute value of iMaxLen
      integer :: iLenStrF ! length of the Fortran string declared
      integer :: iNdx ! index to the current character being worked on
      integer :: iCount ! number of non-null characters being copied
      logical :: bNull ! to indicate NULL character being reached in strC
      logical :: bSpaceFill ! to indicate space fill is requested

      iLenStrF = LEN(strF)
      iCount = 0
      iNdx = 1
      bNull = .false.
      if (iMaxLen .eq. 0) then
          ! null-terminated Fortran string is requested
          do while (iNdx .le. iLenStrF .and. .not. bNull)
              if (strC(iNdx) .eq. CHAR(0)) then
                  strF(iNdx:iNdx) = strC(iNdx) ! Null termination
                  bNull = .true.
              else
                  strF(iNdx:iNdx) = strC(iNdx)
                  iCount = iCount + 1
              end if
              iNdx = iNdx + 1
          end do
          if (.not. bNull) then
              strF(iLenStrF:iLenStrF) = CHAR(0)
              iCount = iCount - 1
          end if
      else
          if (iMaxLen .lt. 0) then
              bSpaceFill = .false.
              iMaxLenAbs = -iMaxLen
          else
              bSpaceFill = .true.
              iMaxLenAbs = iMaxLen
          end if

          do while (iNdx .le. iLenStrF)
              ! we don't want to stop when null is encountered in strC
              if (.not. bNull .and. strC(iNdx) .eq. CHAR(0)) then
                  bNull = .true.
              end if
              ! copy up to null in strC or to the max length specified
              if (.not. bNull .and. iNdx .le. iMaxLenAbs) then
                  strF(iNdx:iNdx) = strC(iNdx)
                  iCount = iCount + 1
              else if (bSpaceFill) then
                  strF(iNdx:iNdx) = ' ' ! no copy, fill in space in strF
              else
                  exit ! no copy and no fill, just exit
              end if
              iNdx = iNdx + 1
          end do
      end if

      convertStringCtoF = iCount
      return
      end

! Base_Channel.f
! - DLL routines for class <Component>Base.Channel
! DATE: Sunday, April 21, 2002 TIME: 04:53:35 PM
! The skeleton of this file is generated by SansGUI(tm)

! Attribute indices in class version [1.0.0.0]
! 1: iNumber - Channel Number
! 2: rRef - MIDI Message Object

! ======================================================================
! SG_xEval - Evaluation
! ----------------------------------------------------------------------
integer function SG_xEval_Base_Channel(self,                            &
     &                        simCtrl, chgChild,                        &
     &                        pRefObjs, iRefObjs,                       &
     &                        pAdjObjs, iAdjObjs,                       &
     &                        pLnkObjs, iLnkObjs,                       &
     &                        cMessage, cCommand, pOutFile )
!DEC$ IF DEFINED (_DLL)
!DEC$ ATTRIBUTES DLLEXPORT :: SG_xEval_Base_Channel
!DEC$ END IF
      include "SGdllf.h"

      ! TODO: declare your local variables here

      integer :: get_MIDI_Channel_Data
      integer :: iMidiChannel, iMidiData
      integer, dimension(*) :: iNumber
      integer, dimension(*) :: iDataM
      type (SG_OBJ) :: rMidiObj
      POINTER(PTR_iNumber, iNumber)
      POINTER(PTR_iDataM, iDataM)
      POINTER(PTR_rMidiObj, rMidiObj)
      integer, parameter :: SG_NDX_INUMBER = 1
      integer, parameter :: SG_NDX_RREF = 2
      integer, parameter :: SG_NDX_IDATA = 3

      if (self%nSGobjSchema .ne. SG_OBJ_SCHEMA) then
          SG_xEval_Base_Channel = SG_R_SCHM
          return
      end if

      ! TODO: put your simulator code here

      ! a MIDI reference object is required
      if (iRefObjs .lt. 1) then
          cMessage = 'Reference to a common MIDI object is required.'C
          SG_xEval_Base_Channel = SG_R_STOP
          return
      end if

      ! Although this class does not contain the data field with index

      ! SG_NDX_IDATA, this function uses it as a common properties in the

      ! subclasses.  The subclass functions call this base class function

      ! for default behavior.
      ! To prevent users from creating any instance of this class; hence,
      ! corrupting the memory, we simply define this class as an abstract

      ! class in the Schema Definition.
      if (self%iNumVars .ge. SG_NDX_IDATA) then
          PTR_rMidiObj = pRefObjs(1)
          PTR_zValues = self%pzValues
          PTR_iNumber = zValues(SG_NDX_INUMBER)%vData
          PTR_iDataM = zValues(SG_NDX_IDATA)%vData
          iMidiChannel = get_MIDI_Channel_Data(rMidiObj, iMidiData)
          ! copy the data field from the MIDI object if the channel number

          ! matches
          if (iMidiChannel .eq. iNumber(1)) then
              iDataM(1) = iMidiData
          end if
      end if

! Base_Channel_S_1.f
! - DLL routines for class <Component>Base.Channel.S-1
! DATE: Sunday, April 21, 2002 TIME: 04:53:35 PM
! The skeleton of this file is generated by SansGUI(tm)

! Attribute indices in class version [1.0.0.0]
! 1: iNumber - Channel Number
! 2: rRef - MIDI Message Object
! 3: iData - MIDI Data

! ======================================================================
! SG_xEval - Evaluation
! ----------------------------------------------------------------------
integer function SG_xEval_Base_Channel_S_1(self,                        &
     &                        simCtrl, chgChild,                        &
     &                        pRefObjs, iRefObjs,                       &
     &                        pAdjObjs, iAdjObjs,                       &
     &                        pLnkObjs, iLnkObjs,                       &
     &                        cMessage, cCommand, pOutFile )
!DEC$ IF DEFINED (_DLL)
!DEC$ ATTRIBUTES DLLEXPORT :: SG_xEval_Base_Channel_S_1
!DEC$ END IF
      include "SGdllf.h"

      ! TODO: declare your local variables here

      integer :: SG_xEval_Base_Channel

      if (self%nSGobjSchema .ne. SG_OBJ_SCHEMA) then
          SG_xEval_Base_Channel_S_1 = SG_R_SCHM
          return
      end if

      ! TODO: put your simulator code here