Путь к истине

Информация о пользователе

Привет, Гость! Войдите или зарегистрируйтесь.

Вы здесь » Путь к истине » Программирование » Генератор стилей акордов Midi

Генератор стилей акордов Midi

Страница: 1

Сообщений 1 страница 18 из 18

1

  • Автор: megalyrik
  • Администратор
  • megalyrik
  • Зарегистрирован: 2010-03-13
  • Приглашений: 0
  • Сообщений: 584
  • Уважение: [+1/-0]
  • Позитив: [+6/-0]
  • Пол: Мужской
  • Провел на форуме:
    5 дней 4 часа
  • Последний визит:
    2026-01-11 20:18:39

Сегодня закончил первую часть проекта по созданию композитора.
Это генератор стилей аккордов .
Задаются аккорды (4) и паттерны для каждой ноты. Затем программа запишет midi файл, который можео будет открыть в любом нотном редакторе
или импортировать в DAW.
https://upforme.ru/uploads/000c/49/0b/2/t964350.png

0

2

  • Автор: megalyrik
  • Администратор
  • megalyrik
  • Зарегистрирован: 2010-03-13
  • Приглашений: 0
  • Сообщений: 584
  • Уважение: [+1/-0]
  • Позитив: [+6/-0]
  • Пол: Мужской
  • Провел на форуме:
    5 дней 4 часа
  • Последний визит:
    2026-01-11 20:18:39

Это старый проект, который несколько лет пролежал в столе, так как были трудности , с которыми не было в тот момент возможности разобраться.
Но время идёт, и потихоньку нащупал подход к решению  проблемных вопросов.
Первую часть связанную со стилями аккордов решил, теперь нет ограничений по нотам с точкой и паузам в конце тактов.
Скоро приступлю ко второй части, алгоритмам формирования Соло трека. Вернее будет несколько алгоритмов на выбор, часть алгоритмов уже продумана,
так что всё это появится довольно скоро.  А пока коды того, что есть, генератора стилей по паттернам.
Прогу пишу в Lazarus.

Код:
unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
  LCLProc, LazUTF8;

type
    brt = array of byte;  // Байт Рекорд Тайп)))
  { TForm1 }

  TForm1 = class(TForm)
    Button2: TButton;
    CheckBox1: TCheckBox;
    CheckBox2: TCheckBox;
    CheckBox3: TCheckBox;
    CheckBox4: TCheckBox;
    Edit1: TEdit;
    Edit2: TEdit;
    Label1: TLabel;
    ListBox1: TListBox;
    ListBox2: TListBox;
    ListBox3: TListBox;
    ListBox4: TListBox;
    ListBox5: TListBox;
    ListBox6: TListBox;
    ListBox7: TListBox;
    SaveDialog1: TSaveDialog;

    procedure fourtime1();
    procedure fourtime2();
    procedure fourtime3();
    procedure fourtime4();

    procedure formacc();
    procedure Button2Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure parspatt(qqq: integer; patt: string);
    procedure pattmass(channum: integer; var chann0: brt);



  private
    { private declarations }
  public
    { public declarations }
  end;

var
  Form1: TForm1;
  accpatt: array[0..140] of integer; //массив паттерна аккорда
  chann1:brt;  //  канал тоники
  chann2:brt;  //  канал субдоминанты
  chann3:brt;  //  канал доминанты
  chann4:brt;  //   канал мелодии
  chann5: array[0..46] of byte = ($4D, $54, $68, $64, $0, $0, $0, $6, $0, $1, $0, $5, $4, $0, $4D, $54, $72, $6B, $0, $0, $0, $19, $0, $FF, $58, $4, $4, $2, $18, $8, $0, $FF, $59, $2, $0, $0, $0, $FF, $51, $3, $7, $A1, $20, $0, $FF, $2F, $0);
  //   служебный канал миди файла и заголовок.

  tonika1: byte;
  subdomin1: byte;
  domin1: byte;
  tonika2: byte;
  subdomin2: byte;
  domin2: byte;
  tonika3: byte;
  subdomin3: byte;
  domin3: byte;
  tonika4: byte;
  subdomin4: byte;
  domin4: byte;
  FileWork: string;

0

3

  • Автор: megalyrik
  • Администратор
  • megalyrik
  • Зарегистрирован: 2010-03-13
  • Приглашений: 0
  • Сообщений: 584
  • Уважение: [+1/-0]
  • Позитив: [+6/-0]
  • Пол: Мужской
  • Провел на форуме:
    5 дней 4 часа
  • Последний визит:
    2026-01-11 20:18:39

accpatt: array[0..140] of integer; //массив паттерна аккорда -
в этом масиве формируются треки, по структуре нота- длительность.
конец трека -255
пауза - 0

Код:
implementation

{$R *.lfm}

{ TForm1 }

procedure TForm1.formacc; //формирует ноты для 4 аккордов
var
   ffl1: byte;
   ffl2: byte;
   ffl3: byte;
   ffl4: byte;
begin
 tonika1 := ListBox1.ItemIndex + 45;
 tonika2 := ListBox2.ItemIndex + 45;
 tonika3 := ListBox3.ItemIndex + 45;
 tonika4 := ListBox4.ItemIndex + 45;
 if (CheckBox1.Checked = False) then ffl1:=0
    else ffl1:=1;
 if (CheckBox2.Checked = False) then ffl2:=0
    else ffl2:=1;
 if (CheckBox3.Checked = False) then ffl3:=0
    else ffl3:=1;
 if (CheckBox4.Checked = False) then ffl4:=0
    else ffl4:=1;
  subdomin1:= tonika1+4 - ffl1;
  subdomin2:= tonika2+4 - ffl2;
  subdomin3:= tonika3+4 - ffl3;
  subdomin4:= tonika4+4 - ffl4;
  domin1:= tonika1+7;
  domin2:= tonika2+7;
  domin3:= tonika3+7;
  domin4:= tonika4+7;
end;

 procedure TForm1.fourtime1;
var

nn4: integer;
begin
  parspatt(0,ListBox5.Items[ListBox5.ItemIndex]);
 parspatt(33,ListBox6.Items[ListBox6.ItemIndex]);
 parspatt(66,ListBox7.Items[ListBox7.ItemIndex]);
 parspatt(99,'1,4,1,4,1,4,1,4,255');

    for nn4:= 0 to 32 do
      begin
       if  (accpatt[nn4] = 1) then  accpatt[nn4]:= tonika1;
      end;
   for nn4:= 33 to 65 do
      begin
       if  (accpatt[nn4] = 1) then  accpatt[nn4]:= subdomin1;
      end;
   for nn4:= 66 to 98 do
      begin
       if  (accpatt[nn4] = 1) then  accpatt[nn4]:= domin1;
      end;
    accpatt[99]:= 0;
   accpatt[101]:= 0;
   accpatt[103]:= 0;
   accpatt[105]:= 0;
   //accpatt[99]:= tonika1;
   //accpatt[101]:= subdomin1;
   //accpatt[103]:= domin1;
   //accpatt[105]:= subdomin1;
end;
procedure TForm1.fourtime2;
var

nn4: integer;
begin
  parspatt(0,ListBox5.Items[ListBox5.ItemIndex]);
 parspatt(33,ListBox6.Items[ListBox6.ItemIndex]);
 parspatt(66,ListBox7.Items[ListBox7.ItemIndex]);
parspatt(99,'1,4,1,4,1,4,1,4,255');

    for nn4:= 0 to 32 do
      begin
       if  (accpatt[nn4] = 1) then  accpatt[nn4]:= tonika2;
      end;
   for nn4:= 33 to 65 do
      begin
       if  (accpatt[nn4] = 1) then  accpatt[nn4]:= subdomin2;
      end;
   for nn4:= 66 to 98 do
      begin
       if  (accpatt[nn4] = 1) then  accpatt[nn4]:= domin2;
      end;

     accpatt[99]:= 0;
   accpatt[101]:= 0;
   accpatt[103]:= 0;
   accpatt[105]:= 0;
   //accpatt[99]:= tonika1;
   //accpatt[101]:= subdomin1;
   //accpatt[103]:= domin1;
   //accpatt[105]:= subdomin1;
end;

0

4

  • Автор: megalyrik
  • Администратор
  • megalyrik
  • Зарегистрирован: 2010-03-13
  • Приглашений: 0
  • Сообщений: 584
  • Уважение: [+1/-0]
  • Позитив: [+6/-0]
  • Пол: Мужской
  • Провел на форуме:
    5 дней 4 часа
  • Последний визит:
    2026-01-11 20:18:39

Под subdomin1 имеется вв виду не субдоминанта, а всего лишь третья ступень тональности.
Назвал субдоминантой чисто из удобства (между тоникой и доминантой).
Объясняю это для любителей теории музыки, которые будут цепляться к словам.
Теория конечно будет, но уже на следующей стадии разработки...

Код:

procedure TForm1.fourtime3;
var

nn4: integer;
begin
  parspatt(0,ListBox5.Items[ListBox5.ItemIndex]);
 parspatt(33,ListBox6.Items[ListBox6.ItemIndex]);
 parspatt(66,ListBox7.Items[ListBox7.ItemIndex]);
parspatt(99,'1,4,1,4,1,4,1,4,255');

    for nn4:= 0 to 32 do
      begin
       if  (accpatt[nn4] = 1) then  accpatt[nn4]:= tonika3;
      end;
   for nn4:= 33 to 65 do
      begin
       if  (accpatt[nn4] = 1) then  accpatt[nn4]:= subdomin3;
      end;
   for nn4:= 66 to 98 do
      begin
       if  (accpatt[nn4] = 1) then  accpatt[nn4]:= domin3;
      end;

   for nn4:= 0 to 32 do
     accpatt[99]:= 0;
   accpatt[101]:= 0;
   accpatt[103]:= 0;
   accpatt[105]:= 0;
   //accpatt[99]:= tonika1;
   //accpatt[101]:= subdomin1;
   //accpatt[103]:= domin1;
   //accpatt[105]:= subdomin1;
end;
procedure TForm1.fourtime4;
var

nn4: integer;
begin
  parspatt(0,ListBox5.Items[ListBox5.ItemIndex]);
 parspatt(33,ListBox6.Items[ListBox6.ItemIndex]);
 parspatt(66,ListBox7.Items[ListBox7.ItemIndex]);
parspatt(99,'1,4,1,4,1,4,1,4,255');

    for nn4:= 0 to 32 do
      begin
       if  (accpatt[nn4] = 1) then  accpatt[nn4]:= tonika4;
      end;
   for nn4:= 33 to 65 do
      begin
       if  (accpatt[nn4] = 1) then  accpatt[nn4]:= subdomin4;
      end;
   for nn4:= 66 to 98 do
      begin
       if  (accpatt[nn4] = 1) then  accpatt[nn4]:= domin4;
      end;
     accpatt[99]:= 0;
   accpatt[101]:= 0;
   accpatt[103]:= 0;
   accpatt[105]:= 0;
   //accpatt[99]:= tonika1;
   //accpatt[101]:= subdomin1;
   //accpatt[103]:= domin1;
   //accpatt[105]:= subdomin1;
end;

0

5

  • Автор: megalyrik
  • Администратор
  • megalyrik
  • Зарегистрирован: 2010-03-13
  • Приглашений: 0
  • Сообщений: 584
  • Уважение: [+1/-0]
  • Позитив: [+6/-0]
  • Пол: Мужской
  • Провел на форуме:
    5 дней 4 часа
  • Последний визит:
    2026-01-11 20:18:39

А вот собственно процедура формирования миди сообщений в каналах и запись всего в файл

Код:
procedure TForm1.Button2Click(Sender: TObject);
var
  nn3, br, br1, br2: integer;
   f: file of byte;
    ki, ci:integer;
begin
  SetLength(chann1,11);
  SetLength(chann2,11);
  SetLength(chann3,11);
  SetLength(chann4,11);
  for ci := 0 to 10 do
   begin
    chann1[ci]:=0;
    chann2[ci]:=0;
    chann3[ci]:=0;
    chann4[ci]:=0;
   end;
    chann1[0]:=$4D;
    chann2[0]:=$4D;
    chann3[0]:=$4D;
    chann4[0]:=$4D;

    chann1[1]:=$54;
    chann2[1]:=$54;
    chann3[1]:=$54;
    chann4[1]:=$54;

    chann1[2]:=$72;
    chann2[2]:=$72;
    chann3[2]:=$72;
    chann4[2]:=$72;

    chann1[3]:=$6B;
    chann2[3]:=$6B;
    chann3[3]:=$6B;
    chann4[3]:=$6B;

    chann1[9]:=$C0;
    chann2[9]:=$C1;
    chann3[9]:=$C2;
    chann4[9]:=$C3;

    chann1[10]:=0; //пианино
    chann2[10]:=0;
    chann3[10]:=0;
    chann4[10]:=$2A; //инструмент

 If Form1.SaveDialog1.Execute then
  begin
  FileWork:=Utf8ToSys(Form1.SaveDialog1.FileName);
  AssignFile(f, FileWork);
  Rewrite(f);
  end;
       // AssignFile(f, 'f:\myfile.mid');
  formacc;
  for ki:= 1 to StrToInt(Edit1.Text) do
   begin
 fourtime1;
   pattmass(1,chann1);   // формируем массивы с миди
  pattmass(2,chann2);
  pattmass(3,chann3);
  pattmass(4,chann4);
 fourtime2;
   pattmass(1,chann1);
  pattmass(2,chann2);
  pattmass(3,chann3);
  pattmass(4,chann4);
 fourtime3;
   pattmass(1,chann1);
  pattmass(2,chann2);
  pattmass(3,chann3);
  pattmass(4,chann4);
 fourtime4;
   pattmass(1,chann1);
  pattmass(2,chann2);
  pattmass(3,chann3);
  pattmass(4,chann4);
  end;

   SetLength(chann1,length(chann1)+4);  //добавляем нужные байты
    chann1[length(chann1)-4]:= 0;
    chann1[length(chann1)-3]:= $FF;
    chann1[length(chann1)-2]:= $2F;
    chann1[length(chann1)-1]:= 0;
    br := length(chann1)-8;
    br1 := Trunc(br / 256);
    br2 := br - (br1 * 256);
    chann1[6]:= br1;
    chann1[7]:= br2;

   SetLength(chann2,length(chann2)+4);
    chann2[length(chann2)-4]:= 0;
    chann2[length(chann2)-3]:= $FF;
    chann2[length(chann2)-2]:= $2F;
    chann2[length(chann2)-1]:= 0;
    br := length(chann2)-8;
    br1 := Trunc(br / 256);
    br2 := br - (br1 * 256);
    chann2[6]:= br1;
    chann2[7]:= br2;

   SetLength(chann3,length(chann3)+4);
    chann3[length(chann3)-4]:= 0;
    chann3[length(chann3)-3]:= $FF;
    chann3[length(chann3)-2]:= $2F;
    chann3[length(chann3)-1]:= 0;
    br := length(chann3)-8;
    br1 := Trunc(br / 256);
    br2 := br - (br1 * 256);
    chann3[6]:= br1;
    chann3[7]:= br2;

   SetLength(chann4,length(chann4)+4);
    chann4[length(chann4)-4]:= 0;
    chann4[length(chann4)-3]:= $FF;
    chann4[length(chann4)-2]:= $2F;
    chann4[length(chann4)-1]:= 0;
    br := length(chann4)-8;
    br1 := Trunc(br / 256);
    br2 := br - (br1 * 256);
    chann4[6]:= br1;
    chann4[7]:= br2;

  for nn3:= 0 to length(chann5)-1 do  //записываем миди файл
  begin
    write(f,chann5[nn3]);
  end;

 for nn3:= 0 to length(chann1)-1 do
  begin
    write(f,chann1[nn3]);
  end;

 for nn3:= 0 to length(chann2)-1 do
  begin
    write(f,chann2[nn3]);
  end;

  for nn3:= 0 to length(chann3)-1 do
  begin
    write(f,chann3[nn3]);
  end;

   for nn3:= 0 to length(chann4)-1 do
  begin
    write(f,chann4[nn3]);
  end;

 CloseFile(f);
end;

0

6

  • Автор: megalyrik
  • Администратор
  • megalyrik
  • Зарегистрирован: 2010-03-13
  • Приглашений: 0
  • Сообщений: 584
  • Уважение: [+1/-0]
  • Позитив: [+6/-0]
  • Пол: Мужской
  • Провел на форуме:
    5 дней 4 часа
  • Последний визит:
    2026-01-11 20:18:39

А дальше вспомагательные процедуры .
Сначало парсинг списков паттернов

Код:
procedure TForm1.FormCreate(Sender: TObject);
 var ci:integer;
begin
  ListBox5.Items.LoadFromFile('tonika.txt');
  ListBox6.Items.LoadFromFile('subdomina.txt');
  ListBox7.Items.LoadFromFile('domina.txt');
  SetLength(chann1,11);
  SetLength(chann2,11);
  SetLength(chann3,11);
  SetLength(chann4,11);
  for ci := 0 to 10 do
   begin
    chann1[ci]:=0;
    chann2[ci]:=0;
    chann3[ci]:=0;
    chann4[ci]:=0;
   end;
    chann1[0]:=$4D;
    chann2[0]:=$4D;
    chann3[0]:=$4D;
    chann4[0]:=$4D;

    chann1[1]:=$54;
    chann2[1]:=$54;
    chann3[1]:=$54;
    chann4[1]:=$54;

    chann1[2]:=$72;
    chann2[2]:=$72;
    chann3[2]:=$72;
    chann4[2]:=$72;

    chann1[3]:=$6B;
    chann2[3]:=$6B;
    chann3[3]:=$6B;
    chann4[3]:=$6B;

    chann1[9]:=$C0;
    chann2[9]:=$C1;
    chann3[9]:=$C2;
    chann4[9]:=$C3;

    chann1[10]:=0; //пианино
    chann2[10]:=0;
    chann3[10]:=0;
    chann4[10]:=$2A; //инструмент
end;



procedure TForm1.parspatt(qqq: integer; patt: string);  // расскладывает стринг на числа
var
 posstart, i, n: Integer;
begin
  posstart:=0;
   n:= 0;
   i:= qqq;

repeat
 if posstart = length(patt)+1 then break;
    n:=0;
      posstart:= posstart+1;
    while Copy(patt, posstart, 1)<>','  do
      begin
      if posstart = length(patt)+1 then break;
      posstart:= posstart+1;
      n:=n+1;
      end;
       accpatt[i]:= StrToInt(Copy(patt, posstart-n,n));
       i:= i+ 1;
until false;
end;

0

7

  • Автор: megalyrik
  • Администратор
  • megalyrik
  • Зарегистрирован: 2010-03-13
  • Приглашений: 0
  • Сообщений: 584
  • Уважение: [+1/-0]
  • Позитив: [+6/-0]
  • Пол: Мужской
  • Провел на форуме:
    5 дней 4 часа
  • Последний визит:
    2026-01-11 20:18:39

И самая важная процедура - формирование из патернов каналов с midi.

Код:
procedure TForm1.pattmass(channum: integer; var chann0: brt);//  патерн транслирует в миди
var
   basis1:integer;
   lenm: integer;
begin
 lenm := channum- 1;
 if (channum= 1) then basis1 :=0;
 if (channum= 2) then basis1 :=33;
 if (channum= 3) then basis1 :=66;
 if (channum= 4) then basis1 :=99;
 while (accpatt[basis1]) <>255 do
 begin
     case accpatt[basis1] of
     0: begin
                         SetLength(chann0,length(chann0)+9);
                         chann0[length(chann0)-9]:= 0;
                         chann0[length(chann0)-8]:= lenm+144;
                         chann0[length(chann0)-7]:= $40;
                         chann0[length(chann0)-6]:= $00;
                         if  (accpatt[basis1+1]=0)  then
                         begin

                         chann0[length(chann0)-5]:= $A0;
                         chann0[length(chann0)-4]:= 0;
                         end;
                         if  (accpatt[basis1+1]=2)  then
                         begin

                         chann0[length(chann0)-5]:= $90;
                         chann0[length(chann0)-4]:= 0;
                         end;
                         if  (accpatt[basis1+1]=3)  then
                         begin

                         chann0[length(chann0)-5]:= $98;
                         chann0[length(chann0)-4]:= 0;
                         end;
                         if  (accpatt[basis1+1]=4)  then
                         begin

                         chann0[length(chann0)-5]:= $88;
                         chann0[length(chann0)-4]:= 0;
                         end;
                         if  (accpatt[basis1+1]=5)  then
                         begin

                         chann0[length(chann0)-5]:= $8C;
                         chann0[length(chann0)-4]:= 0;
                         end;
                         if  (accpatt[basis1+1]=8)  then
                         begin

                         chann0[length(chann0)-5]:= $84;
                         chann0[length(chann0)-4]:= 0;
                         end;
                          if  (accpatt[basis1+1]=9)  then
                         begin

                         chann0[length(chann0)-5]:= $86;
                         chann0[length(chann0)-4]:= 0;
                         end;
                         if  (accpatt[basis1+1]=16)  then
                         begin

                         chann0[length(chann0)-5]:= $82;
                         chann0[length(chann0)-4]:= 0;
                         end;
                         chann0[length(chann0)-3]:= lenm+128;
                         chann0[length(chann0)-2]:= $40;
                         chann0[length(chann0)-1]:= 0;
                          basis1:= basis1+2;
               end;
         255:  lenm := 0;
        else
                    begin
                    SetLength(chann0,length(chann0)+9);
                    chann0[length(chann0)-9]:= 0;
                    chann0[length(chann0)-8]:= lenm+144;
                    chann0[length(chann0)-7]:= accpatt[basis1];
                    chann0[length(chann0)-6]:= $40;
                    if  (accpatt[basis1+1]=0)  then
                    begin

                    chann0[length(chann0)-5]:= $A0;
                    chann0[length(chann0)-4]:= 0;
                    end;
                    if  (accpatt[basis1+1]=2)  then
                    begin

                    chann0[length(chann0)-5]:= $90;
                    chann0[length(chann0)-4]:= 0;
                    end;
                    if  (accpatt[basis1+1]=3)  then
                    begin

                    chann0[length(chann0)-5]:= $98;
                    chann0[length(chann0)-4]:= 0;
                    end;
                    if  (accpatt[basis1+1]=4)  then
                    begin

                    chann0[length(chann0)-5]:= $88;
                    chann0[length(chann0)-4]:= 0;
                    end;
                     if  (accpatt[basis1+1]=5)  then
                    begin

                    chann0[length(chann0)-5]:= $8C;
                    chann0[length(chann0)-4]:= 0;
                    end;
                    if  (accpatt[basis1+1]=8)  then
                    begin

                    chann0[length(chann0)-5]:= $84;
                    chann0[length(chann0)-4]:= 0;
                    end;
                     if  (accpatt[basis1+1]=9)  then
                    begin

                    chann0[length(chann0)-5]:= $86;
                    chann0[length(chann0)-4]:= 0;
                    end;
                    if  (accpatt[basis1+1]=16)  then
                    begin

                    chann0[length(chann0)-5]:= $82;
                    chann0[length(chann0)-4]:= 0;
                    end;
                    chann0[length(chann0)-3]:= lenm+128;
                    chann0[length(chann0)-2]:= accpatt[basis1];
                    chann0[length(chann0)-1]:= 0;
                     basis1:= basis1+2;
                    end;

        end;
     end;

end;

end.

Ну вот пока всё. Всё работает и без косяков.
Суоро приступаю к главному -авто композитору, там будет и патерный подход и алгоритмы с разрешением в тонику или доминанту
следующего аккорда и алгоритмы на фракталах и генераторах случайных чисел.. планы и идеи великие,  и это на долго)))

0

8

  • Автор: megalyrik
  • Администратор
  • megalyrik
  • Зарегистрирован: 2010-03-13
  • Приглашений: 0
  • Сообщений: 584
  • Уважение: [+1/-0]
  • Позитив: [+6/-0]
  • Пол: Мужской
  • Провел на форуме:
    5 дней 4 часа
  • Последний визит:
    2026-01-11 20:18:39

Не стал откладывать на потом. Разработал новый формат патерна для линии мелодии
Формат патерна для мелодии:
1 байт
   0= пауза
   44= тоника
   1..43=приращение в полутонах к тонике.
2 байт длительность  как в предыдущем описании

последний байт 255
Теперь осталось только научить программу генерировать паттерны в зависимости от аккордов(мажор-минор)
и разрешать в соседний патерн.
А вот новые процедуры сборки патернов.

Код:
 procedure TForm1.fourtime1;
var
p1: boolean;
nn4: integer;
begin
  parspatt(0,ListBox5.Items[ListBox5.ItemIndex]);
 parspatt(33,ListBox6.Items[ListBox6.ItemIndex]);
 parspatt(66,ListBox7.Items[ListBox7.ItemIndex]);
 parspatt(99,'44,4,3,4,7,4,44,4,255');
 p1:= true;

    for nn4:= 0 to 32 do
      begin
       if  (accpatt[nn4] = 1) then  accpatt[nn4]:= tonika1;
      end;
   for nn4:= 33 to 65 do
      begin
       if  (accpatt[nn4] = 1) then  accpatt[nn4]:= subdomin1;
      end;
   for nn4:= 66 to 98 do
      begin
       if  (accpatt[nn4] = 1) then  accpatt[nn4]:= domin1;
      end;
   nn4:= 99;
    while p1 = true do
      begin
      if  (accpatt[nn4] = 255) then  break;
      if  (accpatt[nn4] = 0) then
          begin
          accpatt[nn4]:= 0;
          nn4:= nn4 + 2;
          end;
      if  (accpatt[nn4] = 44) then
          begin
          accpatt[nn4]:= tonika1;
          nn4:= nn4 + 2;
          end
      else
          begin
          accpatt[nn4]:= tonika1 + accpatt[nn4];
          nn4:= nn4 + 2;
          end;

      end;

   //accpatt[99]:= tonika1;
   //accpatt[101]:= subdomin1;
   //accpatt[103]:= domin1;
   //accpatt[105]:= subdomin1;
end;
procedure TForm1.fourtime2;
var
p1: boolean;
nn4: integer;
begin
  parspatt(0,ListBox5.Items[ListBox5.ItemIndex]);
 parspatt(33,ListBox6.Items[ListBox6.ItemIndex]);
 parspatt(66,ListBox7.Items[ListBox7.ItemIndex]);
 parspatt(99,'44,4,3,4,7,4,44,4,255');
 p1:= true;

    for nn4:= 0 to 32 do
      begin
       if  (accpatt[nn4] = 1) then  accpatt[nn4]:= tonika2;
      end;
   for nn4:= 33 to 65 do
      begin
       if  (accpatt[nn4] = 1) then  accpatt[nn4]:= subdomin2;
      end;
   for nn4:= 66 to 98 do
      begin
       if  (accpatt[nn4] = 1) then  accpatt[nn4]:= domin2;
      end;
   nn4:= 99;
    while p1 = true do
      begin
      if  (accpatt[nn4] = 255) then  break;
      if  (accpatt[nn4] = 0) then
          begin
          accpatt[nn4]:= 0;
          nn4:= nn4 + 2;
          end;
      if  (accpatt[nn4] = 44) then
          begin
          accpatt[nn4]:= tonika2;
          nn4:= nn4 + 2;
          end
      else
          begin
          accpatt[nn4]:= tonika2 + accpatt[nn4];
          nn4:= nn4 + 2;
          end;

      end;

   //accpatt[99]:= tonika2;
   //accpatt[101]:= subdomin2;
   //accpatt[103]:= domin2;
   //accpatt[105]:= subdomin2;
end;
procedure TForm1.fourtime3;
var
p1: boolean;
nn4: integer;
begin
  parspatt(0,ListBox5.Items[ListBox5.ItemIndex]);
 parspatt(33,ListBox6.Items[ListBox6.ItemIndex]);
 parspatt(66,ListBox7.Items[ListBox7.ItemIndex]);
 parspatt(99,'44,4,4,4,7,4,44,4,255');
 p1:= true;

    for nn4:= 0 to 32 do
      begin
       if  (accpatt[nn4] = 1) then  accpatt[nn4]:= tonika3;
      end;
   for nn4:= 33 to 65 do
      begin
       if  (accpatt[nn4] = 1) then  accpatt[nn4]:= subdomin3;
      end;
   for nn4:= 66 to 98 do
      begin
       if  (accpatt[nn4] = 1) then  accpatt[nn4]:= domin3;
      end;
   nn4:= 99;
    while p1 = true do
      begin
      if  (accpatt[nn4] = 255) then  break;
      if  (accpatt[nn4] = 0) then
          begin
          accpatt[nn4]:= 0;
          nn4:= nn4 + 2;
          end;
      if  (accpatt[nn4] = 44) then
          begin
          accpatt[nn4]:= tonika3;
          nn4:= nn4 + 2;
          end
      else
          begin
          accpatt[nn4]:= tonika3 + accpatt[nn4];
          nn4:= nn4 + 2;
          end;

      end;

   //accpatt[99]:= tonika3;
   //accpatt[101]:= subdomin3;
   //accpatt[103]:= domin3;
   //accpatt[105]:= subdomin3;
end;

0

9

  • Автор: megalyrik
  • Администратор
  • megalyrik
  • Зарегистрирован: 2010-03-13
  • Приглашений: 0
  • Сообщений: 584
  • Уважение: [+1/-0]
  • Позитив: [+6/-0]
  • Пол: Мужской
  • Провел на форуме:
    5 дней 4 часа
  • Последний визит:
    2026-01-11 20:18:39

немного там не влезло)))

Код:
procedure TForm1.fourtime4;
var
p1: boolean;
nn4: integer;
begin
  parspatt(0,ListBox5.Items[ListBox5.ItemIndex]);
 parspatt(33,ListBox6.Items[ListBox6.ItemIndex]);
 parspatt(66,ListBox7.Items[ListBox7.ItemIndex]);
 parspatt(99,'44,4,3,4,7,4,44,4,255');
 p1:= true;

    for nn4:= 0 to 32 do
      begin
       if  (accpatt[nn4] = 1) then  accpatt[nn4]:= tonika4;
      end;
   for nn4:= 33 to 65 do
      begin
       if  (accpatt[nn4] = 1) then  accpatt[nn4]:= subdomin4;
      end;
   for nn4:= 66 to 98 do
      begin
       if  (accpatt[nn4] = 1) then  accpatt[nn4]:= domin4;
      end;
   nn4:= 99;
    while p1 = true do
      begin
      if  (accpatt[nn4] = 255) then  break;
      if  (accpatt[nn4] = 0) then
          begin
          accpatt[nn4]:= 0;
          nn4:= nn4 + 2;
          end;
      if  (accpatt[nn4] = 44) then
          begin
          accpatt[nn4]:= tonika4;
          nn4:= nn4 + 2;
          end
      else
          begin
          accpatt[nn4]:= tonika4 + accpatt[nn4];
          nn4:= nn4 + 2;
          end;

      end;

   //accpatt[99]:= tonika4;
   //accpatt[101]:= subdomin4;
   //accpatt[103]:= domin4;
   //accpatt[105]:= subdomin4;
end;

0

10

  • Автор: megalyrik
  • Администратор
  • megalyrik
  • Зарегистрирован: 2010-03-13
  • Приглашений: 0
  • Сообщений: 584
  • Уважение: [+1/-0]
  • Позитив: [+6/-0]
  • Пол: Мужской
  • Провел на форуме:
    5 дней 4 часа
  • Последний визит:
    2026-01-11 20:18:39

Маленькое дополнение.
Ввёл распределение паттернов по минор-мажор.
Осталось только прописать генераторы паттернов, алгоритмов и задумок много)))

Код:
procedure TForm1.fourtime1;
var
p1: boolean;
nn4: integer;
begin
 minorpatt:= '44,4,3,4,7,4,44,4,255';
 majorpatt:= '44,4,4,4,7,4,44,4,255';
 if (ffl1 = 0) then parspatt(99,majorpatt);
 if (ffl1 = 1) then parspatt(99,minorpatt);
 parspatt(0,ListBox5.Items[ListBox5.ItemIndex]);
 parspatt(33,ListBox6.Items[ListBox6.ItemIndex]);
 parspatt(66,ListBox7.Items[ListBox7.ItemIndex]);
 p1:= true;

    for nn4:= 0 to 32 do
      begin
       if  (accpatt[nn4] = 1) then  accpatt[nn4]:= tonika1;
      end;
   for nn4:= 33 to 65 do
      begin
       if  (accpatt[nn4] = 1) then  accpatt[nn4]:= subdomin1;
      end;
   for nn4:= 66 to 98 do
      begin
       if  (accpatt[nn4] = 1) then  accpatt[nn4]:= domin1;
      end;
   nn4:= 99;
    while p1 = true do
      begin
      if  (accpatt[nn4] = 255) then  break;
      if  (accpatt[nn4] = 0) then
          begin
          accpatt[nn4]:= 0;
          nn4:= nn4 + 2;
          end;
      if  (accpatt[nn4] = 44) then
          begin
          accpatt[nn4]:= tonika1;
          nn4:= nn4 + 2;
          end
      else
          begin
          accpatt[nn4]:= tonika1 + accpatt[nn4];
          nn4:= nn4 + 2;
          end;

      end;

   //accpatt[99]:= tonika1;
   //accpatt[101]:= subdomin1;
   //accpatt[103]:= domin1;
   //accpatt[105]:= subdomin1;
end;

0

11

  • Автор: megalyrik
  • Администратор
  • megalyrik
  • Зарегистрирован: 2010-03-13
  • Приглашений: 0
  • Сообщений: 584
  • Уважение: [+1/-0]
  • Позитив: [+6/-0]
  • Пол: Мужской
  • Провел на форуме:
    5 дней 4 часа
  • Последний визит:
    2026-01-11 20:18:39

Сегодня хорошо поработал. Разнёс всё по процедурам, реализовал  выбор паттернов мелодии для аккордов.
Сделал кнопочку, чтобы прослушать в программе созданную мидишку.

Код:
procedure TForm1.Button1Click(Sender: TObject);
begin
mciSendString(PChar('open "' + FileWork + '" alias mySound wait'), nil, 0, 0);
mciSendString(PChar('play mySound wait') , nil, 0, 0);
mciSendString(PChar('close mySound wait') , nil, 0, 0);
end;

0

12

  • Автор: megalyrik
  • Администратор
  • megalyrik
  • Зарегистрирован: 2010-03-13
  • Приглашений: 0
  • Сообщений: 584
  • Уважение: [+1/-0]
  • Позитив: [+6/-0]
  • Пол: Мужской
  • Провел на форуме:
    5 дней 4 часа
  • Последний визит:
    2026-01-11 20:18:39

0

13

  • Автор: megalyrik
  • Администратор
  • megalyrik
  • Зарегистрирован: 2010-03-13
  • Приглашений: 0
  • Сообщений: 584
  • Уважение: [+1/-0]
  • Позитив: [+6/-0]
  • Пол: Мужской
  • Провел на форуме:
    5 дней 4 часа
  • Последний визит:
    2026-01-11 20:18:39

А вот и первый алгоритм.
Он заключается в анализе последующей тоники.
Если разница между тониками больше или равна двум тонам , то предыдущий аккорд заканчивается на третьей ступени!
Алгоритм понимает разницу между минор-мажором.
После более 20 проверок нареканий к алгоритму нет, на некоторых паттернах он дал на удивление интерессный результат. Так что именно этот алгоритм остаётся в еоробке!

Код:
formmgpatt(gpatt1);//паттерн в массив
 gpatt1:= '';
 if (CheckBox5.Checked = False) then jk:=0
    else jk:=1;
 if (ffl1 = 0) then f1:= 4
    else f1:= 3;
 if (ffl3 = 0) then f3:= 4
    else f3:= 3;
 if (tonika1 < tonika2)then
    swap:= tonika2 - tonika1
    else
    swap:= tonika1 - tonika2 ;

  for nnc:= 0 to 32 do   // Алгоритм изменения паттерна
      begin
      if((mgpatt[nnc] = 255) and (jk = 1)) then
      begin
      if (swap >= 4) then mgpatt[nnc - 2]:= f1;
       break
      end
      end;
  for nnc:= 0 to 32 do   //востанавливает паттерн мз массива
      begin
      if(mgpatt[nnc] = 255) then
      begin
       gpatt1:= gpatt1 + IntToStr(mgpatt[nnc]);
       break;
      end
      else
      gpatt1:= gpatt1 + IntToStr(mgpatt[nnc]) + ',';
      end;

  Edit2.Text:= gpatt1;
   formmgpatt(gpatt3);//паттерн в массив
 gpatt3:= '';
   if (tonika3 < tonika4)then
    swap:= tonika4 - tonika3
    else
    swap:= tonika3 - tonika4 ;
  for nnc:= 0 to 32 do   // Алгоритм изменения паттерна
      begin
      if((mgpatt[nnc] = 255) and (jk = 1)) then
      begin
      if(swap >= 4) then mgpatt[nnc - 2]:= f3;
       break
      end
      end;
  for nnc:= 0 to 32 do   //востанавливает паттерн мз массива
      begin
      if(mgpatt[nnc] = 255) then
      begin
       gpatt3:= gpatt3 + IntToStr(mgpatt[nnc]);
       break;
      end
      else
      gpatt3:= gpatt3 + IntToStr(mgpatt[nnc]) + ',';
      end;

0

14

  • Автор: megalyrik
  • Администратор
  • megalyrik
  • Зарегистрирован: 2010-03-13
  • Приглашений: 0
  • Сообщений: 584
  • Уважение: [+1/-0]
  • Позитив: [+6/-0]
  • Пол: Мужской
  • Провел на форуме:
    5 дней 4 часа
  • Последний визит:
    2026-01-11 20:18:39
Код:
procedure TForm1.formmgpatt(patt: string);//разбор паттерна
var
 posstart, i, n: Integer;
begin
  posstart:=0;
   n:= 0;
   i:= 0;

repeat
 if posstart = length(patt)+1 then break;
    n:=0;
      posstart:= posstart+1;
    while Copy(patt, posstart, 1)<>','  do
      begin
      if posstart = length(patt)+1 then break;
      posstart:= posstart+1;
      n:=n+1;
      end;
       mgpatt[i]:= StrToInt(Copy(patt, posstart-n,n));
       i:= i+ 1;
until false;
end;

0

15

  • Автор: megalyrik
  • Администратор
  • megalyrik
  • Зарегистрирован: 2010-03-13
  • Приглашений: 0
  • Сообщений: 584
  • Уважение: [+1/-0]
  • Позитив: [+6/-0]
  • Пол: Мужской
  • Провел на форуме:
    5 дней 4 часа
  • Последний визит:
    2026-01-11 20:18:39

0

16

  • Автор: megalyrik
  • Администратор
  • megalyrik
  • Зарегистрирован: 2010-03-13
  • Приглашений: 0
  • Сообщений: 584
  • Уважение: [+1/-0]
  • Позитив: [+6/-0]
  • Пол: Мужской
  • Провел на форуме:
    5 дней 4 часа
  • Последний визит:
    2026-01-11 20:18:39
Код:
 //ALGORITM 2
  if (jk2 = 1) then
  begin
     formmgpatt(gpatt2);//паттерн в массив
     gpatt2:= '';
     if ((tonika1 - tonika2) > 3) then
      mgpatt[0]:= 7;

    for nnc:= 0 to 32 do   //востанавливает паттерн мз массива
      begin
      if(mgpatt[nnc] = 255) then
      begin
       gpatt2:= gpatt2 + IntToStr(mgpatt[nnc]);
       break;
      end
      else
      gpatt2:= gpatt2 + IntToStr(mgpatt[nnc]) + ',';
      end;
    formmgpatt(gpatt4);//паттерн в массив
     gpatt4:= '';
     if ((tonika3 - tonika4) > 3)then
      mgpatt[0]:= 7;

    for nnc:= 0 to 32 do   //востанавливает паттерн мз массива
      begin
      if(mgpatt[nnc] = 255) then
      begin
       gpatt4:= gpatt4 + IntToStr(mgpatt[nnc]);
       break;
      end
      else
      gpatt4:= gpatt4 + IntToStr(mgpatt[nnc]) + ',';
      end;
   end;

  //ALGORITM 3

  if (jk3 = 1) then
  begin
    formmgpatt(gpatt3);//паттерн в массив
     gpatt3:= '';
     if ((tonika2 - tonika3) > 3)then
      mgpatt[0]:= 7;

    for nnc:= 0 to 32 do   //востанавливает паттерн мз массива
      begin
      if(mgpatt[nnc] = 255) then
      begin
       gpatt3:= gpatt3 + IntToStr(mgpatt[nnc]);
       break;
      end
      else
      gpatt3:= gpatt3 + IntToStr(mgpatt[nnc]) + ',';
      end;
   end;

  //ALGORITM 4

  if (jk4 = 1) then
  begin
    formmgpatt(gpatt3);//паттерн в массив
     gpatt3:= '';
     if ((tonika3 - tonika2) > 3)then
      mgpatt[0]:= -5;

    for nnc:= 0 to 32 do   //востанавливает паттерн мз массива
      begin
      if(mgpatt[nnc] = 255) then
      begin
       gpatt3:= gpatt3 + IntToStr(mgpatt[nnc]);
       break;
      end
      else
      gpatt3:= gpatt3 + IntToStr(mgpatt[nnc]) + ',';
      end;
   end;
 Label4.Caption:= gpatt1;
 Label5.Caption:= gpatt2;
 Label6.Caption:= gpatt3;
 Label7.Caption:= gpatt4;

0

17

  • Автор: megalyrik
  • Администратор
  • megalyrik
  • Зарегистрирован: 2010-03-13
  • Приглашений: 0
  • Сообщений: 584
  • Уважение: [+1/-0]
  • Позитив: [+6/-0]
  • Пол: Мужской
  • Провел на форуме:
    5 дней 4 часа
  • Последний визит:
    2026-01-11 20:18:39
Код:
if (CheckBox5.Checked = False) then jk:=0
    else jk:=1;
 if (CheckBox6.Checked = False) then jk2:=0
    else jk2:=1;
 if (CheckBox7.Checked = False) then jk3:=0
    else jk3:=1;
 if (CheckBox8.Checked = False) then jk4:=0
    else jk4:=1;

 //ALGORITM 1

 if (ffl1 = 0) then f1:= 4
    else f1:= 3;
 if (ffl3 = 0) then f3:= 4
    else f3:= 3;
 if (tonika1 < tonika2)then
    swap:= tonika2 - tonika1
    else
    swap:= tonika1 - tonika2 ;

  formmgpatt(gpatt1);//паттерн в массив
 gpatt1:= '';
  for nnc:= 0 to 32 do   // Алгоритм изменения паттерна
      begin
      if((mgpatt[nnc] = 255) and (jk = 1)) then
      begin
      if (swap >= 4) then mgpatt[nnc - 2]:= f1;
       break
      end
      end;
  for nnc:= 0 to 32 do   //востанавливает паттерн мз массива
      begin
      if(mgpatt[nnc] = 255) then
      begin
       gpatt1:= gpatt1 + IntToStr(mgpatt[nnc]);
       break;
      end
      else
      gpatt1:= gpatt1 + IntToStr(mgpatt[nnc]) + ',';
      end;
   formmgpatt(gpatt3);//паттерн в массив
 gpatt3:= '';
   if (tonika3 < tonika4)then
    swap:= tonika4 - tonika3
    else
    swap:= tonika3 - tonika4 ;
  for nnc:= 0 to 32 do   // Алгоритм изменения паттерна
      begin
      if((mgpatt[nnc] = 255) and (jk = 1)) then
      begin
      if(swap >= 4) then mgpatt[nnc - 2]:= f3;
       break
      end
      end;
  for nnc:= 0 to 32 do   //востанавливает паттерн мз массива
      begin
      if(mgpatt[nnc] = 255) then
      begin
       gpatt3:= gpatt3 + IntToStr(mgpatt[nnc]);
       break;
      end
      else
      gpatt3:= gpatt3 + IntToStr(mgpatt[nnc]) + ',';
      end;

0

18

  • Автор: megalyrik
  • Администратор
  • megalyrik
  • Зарегистрирован: 2010-03-13
  • Приглашений: 0
  • Сообщений: 584
  • Уважение: [+1/-0]
  • Позитив: [+6/-0]
  • Пол: Мужской
  • Провел на форуме:
    5 дней 4 часа
  • Последний визит:
    2026-01-11 20:18:39

Полностью функциональная версия! Писал под себя, так что для других она может показаться неудобной. В следующей версии возможно подумаю над этим.
Важно одно, при сохранении название писать только латиницей и точно пропишите расширение .mid иначе не будет проигрывать файл.
И в колличестве повторов не стоит делать больше 10 (хотя запас до сотни))))
Скачать можно с моего яндекс диска
https://disk.yandex.ru/d/5KBjQ12jtO07JQ
Приятного использования!!!

0

Страница: 1

Вы здесь » Путь к истине » Программирование » Генератор стилей акордов Midi